1.1 --- a/Admin/isatest/isatest-stats Sat Mar 17 12:26:19 2012 +0100
1.2 +++ b/Admin/isatest/isatest-stats Sat Mar 17 12:52:40 2012 +0100
1.3 @@ -32,7 +32,7 @@
1.4 HOL-Isar_Examples
1.5 HOL-Lattice
1.6 HOL-Library-Codegenerator_Test
1.7 - HOL-Matrix
1.8 + HOL-Matrix_LP
1.9 HOL-Metis_Examples
1.10 HOL-MicroJava
1.11 HOL-Mirabelle
2.1 --- a/src/HOL/IsaMakefile Sat Mar 17 12:26:19 2012 +0100
2.2 +++ b/src/HOL/IsaMakefile Sat Mar 17 12:52:40 2012 +0100
2.3 @@ -52,7 +52,7 @@
2.4 HOL-Isar_Examples \
2.5 HOL-Lattice \
2.6 HOL-Library-Codegenerator_Test \
2.7 - HOL-Matrix \
2.8 + HOL-Matrix_LP \
2.9 HOL-Metis_Examples \
2.10 HOL-MicroJava \
2.11 HOL-Mirabelle \
2.12 @@ -1172,22 +1172,26 @@
2.13 @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL SET_Protocol
2.14
2.15
2.16 -## HOL-Matrix
2.17 +## HOL-Matrix_LP
2.18
2.19 -HOL-Matrix: HOL $(LOG)/HOL-Matrix.gz
2.20 +HOL-Matrix_LP: HOL $(LOG)/HOL-Matrix_LP.gz
2.21
2.22 -$(LOG)/HOL-Matrix.gz: $(OUT)/HOL Matrix/ComputeFloat.thy \
2.23 - Matrix/ComputeHOL.thy Matrix/ComputeNumeral.thy \
2.24 - Matrix/Compute_Oracle/Compute_Oracle.thy Matrix/Compute_Oracle/am.ML \
2.25 - Matrix/Compute_Oracle/am_compiler.ML Matrix/Compute_Oracle/am_ghc.ML \
2.26 - Matrix/Compute_Oracle/am_interpreter.ML \
2.27 - Matrix/Compute_Oracle/am_sml.ML Matrix/Compute_Oracle/compute.ML \
2.28 - Matrix/Compute_Oracle/linker.ML Matrix/Cplex.thy \
2.29 - Matrix/CplexMatrixConverter.ML Matrix/Cplex_tools.ML \
2.30 - Matrix/FloatSparseMatrixBuilder.ML Matrix/LP.thy Matrix/Matrix.thy \
2.31 - Matrix/ROOT.ML Matrix/SparseMatrix.thy Matrix/document/root.tex \
2.32 - Matrix/fspmlp.ML Matrix/matrixlp.ML Tools/float_arith.ML
2.33 - @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL Matrix
2.34 +$(LOG)/HOL-Matrix_LP.gz: $(OUT)/HOL Matrix_LP/ComputeFloat.thy \
2.35 + Matrix_LP/ComputeHOL.thy Matrix_LP/ComputeNumeral.thy \
2.36 + Matrix_LP/Compute_Oracle/Compute_Oracle.thy \
2.37 + Matrix_LP/Compute_Oracle/am.ML \
2.38 + Matrix_LP/Compute_Oracle/am_compiler.ML \
2.39 + Matrix_LP/Compute_Oracle/am_ghc.ML \
2.40 + Matrix_LP/Compute_Oracle/am_interpreter.ML \
2.41 + Matrix_LP/Compute_Oracle/am_sml.ML \
2.42 + Matrix_LP/Compute_Oracle/compute.ML \
2.43 + Matrix_LP/Compute_Oracle/linker.ML Matrix_LP/Cplex.thy \
2.44 + Matrix_LP/CplexMatrixConverter.ML Matrix_LP/Cplex_tools.ML \
2.45 + Matrix_LP/FloatSparseMatrixBuilder.ML Matrix_LP/LP.thy \
2.46 + Matrix_LP/Matrix.thy Matrix_LP/ROOT.ML Matrix_LP/SparseMatrix.thy \
2.47 + Matrix_LP/document/root.tex Matrix_LP/fspmlp.ML \
2.48 + Matrix_LP/matrixlp.ML Tools/float_arith.ML
2.49 + @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL Matrix_LP
2.50
2.51
2.52 ## TLA
2.53 @@ -1901,9 +1905,9 @@
2.54 $(LOG)/HOL-Lattice $(LOG)/HOL-Lattice.gz \
2.55 $(LOG)/HOL-Lex.gz $(LOG)/HOL-Library.gz \
2.56 $(LOG)/HOL-Library-Codegenerator_Test.gz \
2.57 - $(LOG)/HOL-Main.gz $(LOG)/HOL-Matrix \
2.58 - $(LOG)/HOL-Matrix.gz $(LOG)/HOL-Metis_Examples.gz \
2.59 - $(LOG)/HOL-MicroJava.gz $(LOG)/HOL-Mirabelle.gz \
2.60 + $(LOG)/HOL-Main.gz $(LOG)/HOL-Matrix_LP.gz \
2.61 + $(LOG)/HOL-Metis_Examples.gz $(LOG)/HOL-MicroJava.gz \
2.62 + $(LOG)/HOL-Mirabelle.gz \
2.63 $(LOG)/HOL-Multivariate_Analysis.gz \
2.64 $(LOG)/HOL-Mutabelle.gz $(LOG)/HOL-NSA-Examples.gz \
2.65 $(LOG)/HOL-NSA.gz $(LOG)/HOL-NanoJava.gz \
3.1 --- a/src/HOL/Matrix/ComputeFloat.thy Sat Mar 17 12:26:19 2012 +0100
3.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3 @@ -1,309 +0,0 @@
3.4 -(* Title: HOL/Matrix/ComputeFloat.thy
3.5 - Author: Steven Obua
3.6 -*)
3.7 -
3.8 -header {* Floating Point Representation of the Reals *}
3.9 -
3.10 -theory ComputeFloat
3.11 -imports Complex_Main "~~/src/HOL/Library/Lattice_Algebras"
3.12 -uses "~~/src/Tools/float.ML" ("~~/src/HOL/Tools/float_arith.ML")
3.13 -begin
3.14 -
3.15 -definition int_of_real :: "real \<Rightarrow> int"
3.16 - where "int_of_real x = (SOME y. real y = x)"
3.17 -
3.18 -definition real_is_int :: "real \<Rightarrow> bool"
3.19 - where "real_is_int x = (EX (u::int). x = real u)"
3.20 -
3.21 -lemma real_is_int_def2: "real_is_int x = (x = real (int_of_real x))"
3.22 - by (auto simp add: real_is_int_def int_of_real_def)
3.23 -
3.24 -lemma real_is_int_real[simp]: "real_is_int (real (x::int))"
3.25 -by (auto simp add: real_is_int_def int_of_real_def)
3.26 -
3.27 -lemma int_of_real_real[simp]: "int_of_real (real x) = x"
3.28 -by (simp add: int_of_real_def)
3.29 -
3.30 -lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real (int_of_real x) = x"
3.31 -by (auto simp add: int_of_real_def real_is_int_def)
3.32 -
3.33 -lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
3.34 -by (auto simp add: int_of_real_def real_is_int_def)
3.35 -
3.36 -lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
3.37 -apply (subst real_is_int_def2)
3.38 -apply (simp add: real_is_int_add_int_of_real real_int_of_real)
3.39 -done
3.40 -
3.41 -lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
3.42 -by (auto simp add: int_of_real_def real_is_int_def)
3.43 -
3.44 -lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
3.45 -apply (subst real_is_int_def2)
3.46 -apply (simp add: int_of_real_sub real_int_of_real)
3.47 -done
3.48 -
3.49 -lemma real_is_int_rep: "real_is_int x \<Longrightarrow> ?! (a::int). real a = x"
3.50 -by (auto simp add: real_is_int_def)
3.51 -
3.52 -lemma int_of_real_mult:
3.53 - assumes "real_is_int a" "real_is_int b"
3.54 - shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
3.55 - using assms
3.56 - by (auto simp add: real_is_int_def real_of_int_mult[symmetric]
3.57 - simp del: real_of_int_mult)
3.58 -
3.59 -lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
3.60 -apply (subst real_is_int_def2)
3.61 -apply (simp add: int_of_real_mult)
3.62 -done
3.63 -
3.64 -lemma real_is_int_0[simp]: "real_is_int (0::real)"
3.65 -by (simp add: real_is_int_def int_of_real_def)
3.66 -
3.67 -lemma real_is_int_1[simp]: "real_is_int (1::real)"
3.68 -proof -
3.69 - have "real_is_int (1::real) = real_is_int(real (1::int))" by auto
3.70 - also have "\<dots> = True" by (simp only: real_is_int_real)
3.71 - ultimately show ?thesis by auto
3.72 -qed
3.73 -
3.74 -lemma real_is_int_n1: "real_is_int (-1::real)"
3.75 -proof -
3.76 - have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
3.77 - also have "\<dots> = True" by (simp only: real_is_int_real)
3.78 - ultimately show ?thesis by auto
3.79 -qed
3.80 -
3.81 -lemma real_is_int_number_of[simp]: "real_is_int ((number_of \<Colon> int \<Rightarrow> real) x)"
3.82 - by (auto simp: real_is_int_def intro!: exI[of _ "number_of x"])
3.83 -
3.84 -lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
3.85 -by (simp add: int_of_real_def)
3.86 -
3.87 -lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
3.88 -proof -
3.89 - have 1: "(1::real) = real (1::int)" by auto
3.90 - show ?thesis by (simp only: 1 int_of_real_real)
3.91 -qed
3.92 -
3.93 -lemma int_of_real_number_of[simp]: "int_of_real (number_of b) = number_of b"
3.94 - unfolding int_of_real_def
3.95 - by (intro some_equality)
3.96 - (auto simp add: real_of_int_inject[symmetric] simp del: real_of_int_inject)
3.97 -
3.98 -lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
3.99 -by (rule zdiv_int)
3.100 -
3.101 -lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
3.102 -by (rule zmod_int)
3.103 -
3.104 -lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> abs((a::int) div 2) < abs a"
3.105 -by arith
3.106 -
3.107 -lemma norm_0_1: "(0::_::number_ring) = Numeral0 & (1::_::number_ring) = Numeral1"
3.108 - by auto
3.109 -
3.110 -lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
3.111 - by simp
3.112 -
3.113 -lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
3.114 - by simp
3.115 -
3.116 -lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
3.117 - by simp
3.118 -
3.119 -lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
3.120 - by simp
3.121 -
3.122 -lemma int_pow_0: "(a::int)^(Numeral0) = 1"
3.123 - by simp
3.124 -
3.125 -lemma int_pow_1: "(a::int)^(Numeral1) = a"
3.126 - by simp
3.127 -
3.128 -lemma zero_eq_Numeral0_nring: "(0::'a::number_ring) = Numeral0"
3.129 - by simp
3.130 -
3.131 -lemma one_eq_Numeral1_nring: "(1::'a::number_ring) = Numeral1"
3.132 - by simp
3.133 -
3.134 -lemma zero_eq_Numeral0_nat: "(0::nat) = Numeral0"
3.135 - by simp
3.136 -
3.137 -lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
3.138 - by simp
3.139 -
3.140 -lemma zpower_Pls: "(z::int)^Numeral0 = Numeral1"
3.141 - by simp
3.142 -
3.143 -lemma zpower_Min: "(z::int)^((-1)::nat) = Numeral1"
3.144 -proof -
3.145 - have 1:"((-1)::nat) = 0"
3.146 - by simp
3.147 - show ?thesis by (simp add: 1)
3.148 -qed
3.149 -
3.150 -lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
3.151 - by simp
3.152 -
3.153 -lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
3.154 - by simp
3.155 -
3.156 -lemma lift_bool: "x \<Longrightarrow> x=True"
3.157 - by simp
3.158 -
3.159 -lemma nlift_bool: "~x \<Longrightarrow> x=False"
3.160 - by simp
3.161 -
3.162 -lemma not_false_eq_true: "(~ False) = True" by simp
3.163 -
3.164 -lemma not_true_eq_false: "(~ True) = False" by simp
3.165 -
3.166 -lemmas binarith =
3.167 - normalize_bin_simps
3.168 - pred_bin_simps succ_bin_simps
3.169 - add_bin_simps minus_bin_simps mult_bin_simps
3.170 -
3.171 -lemma int_eq_number_of_eq:
3.172 - "(((number_of v)::int)=(number_of w)) = iszero ((number_of (v + uminus w))::int)"
3.173 - by (rule eq_number_of_eq)
3.174 -
3.175 -lemma int_iszero_number_of_Pls: "iszero (Numeral0::int)"
3.176 - by (simp only: iszero_number_of_Pls)
3.177 -
3.178 -lemma int_nonzero_number_of_Min: "~(iszero ((-1)::int))"
3.179 - by simp
3.180 -
3.181 -lemma int_iszero_number_of_Bit0: "iszero ((number_of (Int.Bit0 w))::int) = iszero ((number_of w)::int)"
3.182 - by simp
3.183 -
3.184 -lemma int_iszero_number_of_Bit1: "\<not> iszero ((number_of (Int.Bit1 w))::int)"
3.185 - by simp
3.186 -
3.187 -lemma int_less_number_of_eq_neg: "(((number_of x)::int) < number_of y) = neg ((number_of (x + (uminus y)))::int)"
3.188 - unfolding neg_def number_of_is_id by simp
3.189 -
3.190 -lemma int_not_neg_number_of_Pls: "\<not> (neg (Numeral0::int))"
3.191 - by simp
3.192 -
3.193 -lemma int_neg_number_of_Min: "neg (-1::int)"
3.194 - by simp
3.195 -
3.196 -lemma int_neg_number_of_Bit0: "neg ((number_of (Int.Bit0 w))::int) = neg ((number_of w)::int)"
3.197 - by simp
3.198 -
3.199 -lemma int_neg_number_of_Bit1: "neg ((number_of (Int.Bit1 w))::int) = neg ((number_of w)::int)"
3.200 - by simp
3.201 -
3.202 -lemma int_le_number_of_eq: "(((number_of x)::int) \<le> number_of y) = (\<not> neg ((number_of (y + (uminus x)))::int))"
3.203 - unfolding neg_def number_of_is_id by (simp add: not_less)
3.204 -
3.205 -lemmas intarithrel =
3.206 - int_eq_number_of_eq
3.207 - lift_bool[OF int_iszero_number_of_Pls] nlift_bool[OF int_nonzero_number_of_Min] int_iszero_number_of_Bit0
3.208 - lift_bool[OF int_iszero_number_of_Bit1] int_less_number_of_eq_neg nlift_bool[OF int_not_neg_number_of_Pls] lift_bool[OF int_neg_number_of_Min]
3.209 - int_neg_number_of_Bit0 int_neg_number_of_Bit1 int_le_number_of_eq
3.210 -
3.211 -lemma int_number_of_add_sym: "((number_of v)::int) + number_of w = number_of (v + w)"
3.212 - by simp
3.213 -
3.214 -lemma int_number_of_diff_sym: "((number_of v)::int) - number_of w = number_of (v + (uminus w))"
3.215 - by simp
3.216 -
3.217 -lemma int_number_of_mult_sym: "((number_of v)::int) * number_of w = number_of (v * w)"
3.218 - by simp
3.219 -
3.220 -lemma int_number_of_minus_sym: "- ((number_of v)::int) = number_of (uminus v)"
3.221 - by simp
3.222 -
3.223 -lemmas intarith = int_number_of_add_sym int_number_of_minus_sym int_number_of_diff_sym int_number_of_mult_sym
3.224 -
3.225 -lemmas natarith = add_nat_number_of diff_nat_number_of mult_nat_number_of eq_nat_number_of less_nat_number_of
3.226 -
3.227 -lemmas powerarith = nat_number_of zpower_number_of_even
3.228 - zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
3.229 - zpower_Pls zpower_Min
3.230 -
3.231 -definition float :: "(int \<times> int) \<Rightarrow> real" where
3.232 - "float = (\<lambda>(a, b). real a * 2 powr real b)"
3.233 -
3.234 -lemma float_add_l0: "float (0, e) + x = x"
3.235 - by (simp add: float_def)
3.236 -
3.237 -lemma float_add_r0: "x + float (0, e) = x"
3.238 - by (simp add: float_def)
3.239 -
3.240 -lemma float_add:
3.241 - "float (a1, e1) + float (a2, e2) =
3.242 - (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1) else float (a1*2^(nat (e1-e2))+a2, e2))"
3.243 - by (simp add: float_def algebra_simps powr_realpow[symmetric] powr_divide2[symmetric])
3.244 -
3.245 -lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
3.246 - by (simp add: float_def)
3.247 -
3.248 -lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
3.249 - by (simp add: float_def)
3.250 -
3.251 -lemma float_mult:
3.252 - "float (a1, e1) * float (a2, e2) = (float (a1 * a2, e1 + e2))"
3.253 - by (simp add: float_def powr_add)
3.254 -
3.255 -lemma float_minus:
3.256 - "- (float (a,b)) = float (-a, b)"
3.257 - by (simp add: float_def)
3.258 -
3.259 -lemma zero_le_float:
3.260 - "(0 <= float (a,b)) = (0 <= a)"
3.261 - using powr_gt_zero[of 2 "real b", arith]
3.262 - by (simp add: float_def zero_le_mult_iff)
3.263 -
3.264 -lemma float_le_zero:
3.265 - "(float (a,b) <= 0) = (a <= 0)"
3.266 - using powr_gt_zero[of 2 "real b", arith]
3.267 - by (simp add: float_def mult_le_0_iff)
3.268 -
3.269 -lemma float_abs:
3.270 - "abs (float (a,b)) = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
3.271 - using powr_gt_zero[of 2 "real b", arith]
3.272 - by (simp add: float_def abs_if mult_less_0_iff)
3.273 -
3.274 -lemma float_zero:
3.275 - "float (0, b) = 0"
3.276 - by (simp add: float_def)
3.277 -
3.278 -lemma float_pprt:
3.279 - "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
3.280 - by (auto simp add: zero_le_float float_le_zero float_zero)
3.281 -
3.282 -lemma float_nprt:
3.283 - "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
3.284 - by (auto simp add: zero_le_float float_le_zero float_zero)
3.285 -
3.286 -definition lbound :: "real \<Rightarrow> real"
3.287 - where "lbound x = min 0 x"
3.288 -
3.289 -definition ubound :: "real \<Rightarrow> real"
3.290 - where "ubound x = max 0 x"
3.291 -
3.292 -lemma lbound: "lbound x \<le> x"
3.293 - by (simp add: lbound_def)
3.294 -
3.295 -lemma ubound: "x \<le> ubound x"
3.296 - by (simp add: ubound_def)
3.297 -
3.298 -lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
3.299 - by (auto simp: float_def lbound_def)
3.300 -
3.301 -lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
3.302 - by (auto simp: float_def ubound_def)
3.303 -
3.304 -lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
3.305 - float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound
3.306 -
3.307 -(* for use with the compute oracle *)
3.308 -lemmas arith = binarith intarith intarithrel natarith powerarith floatarith not_false_eq_true not_true_eq_false
3.309 -
3.310 -use "~~/src/HOL/Tools/float_arith.ML"
3.311 -
3.312 -end
4.1 --- a/src/HOL/Matrix/ComputeHOL.thy Sat Mar 17 12:26:19 2012 +0100
4.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
4.3 @@ -1,187 +0,0 @@
4.4 -theory ComputeHOL
4.5 -imports Complex_Main "Compute_Oracle/Compute_Oracle"
4.6 -begin
4.7 -
4.8 -lemma Trueprop_eq_eq: "Trueprop X == (X == True)" by (simp add: atomize_eq)
4.9 -lemma meta_eq_trivial: "x == y \<Longrightarrow> x == y" by simp
4.10 -lemma meta_eq_imp_eq: "x == y \<Longrightarrow> x = y" by auto
4.11 -lemma eq_trivial: "x = y \<Longrightarrow> x = y" by auto
4.12 -lemma bool_to_true: "x :: bool \<Longrightarrow> x == True" by simp
4.13 -lemma transmeta_1: "x = y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
4.14 -lemma transmeta_2: "x == y \<Longrightarrow> y = z \<Longrightarrow> x = z" by simp
4.15 -lemma transmeta_3: "x == y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
4.16 -
4.17 -
4.18 -(**** compute_if ****)
4.19 -
4.20 -lemma If_True: "If True = (\<lambda> x y. x)" by ((rule ext)+,auto)
4.21 -lemma If_False: "If False = (\<lambda> x y. y)" by ((rule ext)+, auto)
4.22 -
4.23 -lemmas compute_if = If_True If_False
4.24 -
4.25 -(**** compute_bool ****)
4.26 -
4.27 -lemma bool1: "(\<not> True) = False" by blast
4.28 -lemma bool2: "(\<not> False) = True" by blast
4.29 -lemma bool3: "(P \<and> True) = P" by blast
4.30 -lemma bool4: "(True \<and> P) = P" by blast
4.31 -lemma bool5: "(P \<and> False) = False" by blast
4.32 -lemma bool6: "(False \<and> P) = False" by blast
4.33 -lemma bool7: "(P \<or> True) = True" by blast
4.34 -lemma bool8: "(True \<or> P) = True" by blast
4.35 -lemma bool9: "(P \<or> False) = P" by blast
4.36 -lemma bool10: "(False \<or> P) = P" by blast
4.37 -lemma bool11: "(True \<longrightarrow> P) = P" by blast
4.38 -lemma bool12: "(P \<longrightarrow> True) = True" by blast
4.39 -lemma bool13: "(True \<longrightarrow> P) = P" by blast
4.40 -lemma bool14: "(P \<longrightarrow> False) = (\<not> P)" by blast
4.41 -lemma bool15: "(False \<longrightarrow> P) = True" by blast
4.42 -lemma bool16: "(False = False) = True" by blast
4.43 -lemma bool17: "(True = True) = True" by blast
4.44 -lemma bool18: "(False = True) = False" by blast
4.45 -lemma bool19: "(True = False) = False" by blast
4.46 -
4.47 -lemmas compute_bool = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10 bool11 bool12 bool13 bool14 bool15 bool16 bool17 bool18 bool19
4.48 -
4.49 -
4.50 -(*** compute_pair ***)
4.51 -
4.52 -lemma compute_fst: "fst (x,y) = x" by simp
4.53 -lemma compute_snd: "snd (x,y) = y" by simp
4.54 -lemma compute_pair_eq: "((a, b) = (c, d)) = (a = c \<and> b = d)" by auto
4.55 -
4.56 -lemma prod_case_simp: "prod_case f (x,y) = f x y" by simp
4.57 -
4.58 -lemmas compute_pair = compute_fst compute_snd compute_pair_eq prod_case_simp
4.59 -
4.60 -(*** compute_option ***)
4.61 -
4.62 -lemma compute_the: "the (Some x) = x" by simp
4.63 -lemma compute_None_Some_eq: "(None = Some x) = False" by auto
4.64 -lemma compute_Some_None_eq: "(Some x = None) = False" by auto
4.65 -lemma compute_None_None_eq: "(None = None) = True" by auto
4.66 -lemma compute_Some_Some_eq: "(Some x = Some y) = (x = y)" by auto
4.67 -
4.68 -definition option_case_compute :: "'b option \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a"
4.69 - where "option_case_compute opt a f = option_case a f opt"
4.70 -
4.71 -lemma option_case_compute: "option_case = (\<lambda> a f opt. option_case_compute opt a f)"
4.72 - by (simp add: option_case_compute_def)
4.73 -
4.74 -lemma option_case_compute_None: "option_case_compute None = (\<lambda> a f. a)"
4.75 - apply (rule ext)+
4.76 - apply (simp add: option_case_compute_def)
4.77 - done
4.78 -
4.79 -lemma option_case_compute_Some: "option_case_compute (Some x) = (\<lambda> a f. f x)"
4.80 - apply (rule ext)+
4.81 - apply (simp add: option_case_compute_def)
4.82 - done
4.83 -
4.84 -lemmas compute_option_case = option_case_compute option_case_compute_None option_case_compute_Some
4.85 -
4.86 -lemmas compute_option = compute_the compute_None_Some_eq compute_Some_None_eq compute_None_None_eq compute_Some_Some_eq compute_option_case
4.87 -
4.88 -(**** compute_list_length ****)
4.89 -
4.90 -lemma length_cons:"length (x#xs) = 1 + (length xs)"
4.91 - by simp
4.92 -
4.93 -lemma length_nil: "length [] = 0"
4.94 - by simp
4.95 -
4.96 -lemmas compute_list_length = length_nil length_cons
4.97 -
4.98 -(*** compute_list_case ***)
4.99 -
4.100 -definition list_case_compute :: "'b list \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'a"
4.101 - where "list_case_compute l a f = list_case a f l"
4.102 -
4.103 -lemma list_case_compute: "list_case = (\<lambda> (a::'a) f (l::'b list). list_case_compute l a f)"
4.104 - apply (rule ext)+
4.105 - apply (simp add: list_case_compute_def)
4.106 - done
4.107 -
4.108 -lemma list_case_compute_empty: "list_case_compute ([]::'b list) = (\<lambda> (a::'a) f. a)"
4.109 - apply (rule ext)+
4.110 - apply (simp add: list_case_compute_def)
4.111 - done
4.112 -
4.113 -lemma list_case_compute_cons: "list_case_compute (u#v) = (\<lambda> (a::'a) f. (f (u::'b) v))"
4.114 - apply (rule ext)+
4.115 - apply (simp add: list_case_compute_def)
4.116 - done
4.117 -
4.118 -lemmas compute_list_case = list_case_compute list_case_compute_empty list_case_compute_cons
4.119 -
4.120 -(*** compute_list_nth ***)
4.121 -(* Of course, you will need computation with nats for this to work \<dots> *)
4.122 -
4.123 -lemma compute_list_nth: "((x#xs) ! n) = (if n = 0 then x else (xs ! (n - 1)))"
4.124 - by (cases n, auto)
4.125 -
4.126 -(*** compute_list ***)
4.127 -
4.128 -lemmas compute_list = compute_list_case compute_list_length compute_list_nth
4.129 -
4.130 -(*** compute_let ***)
4.131 -
4.132 -lemmas compute_let = Let_def
4.133 -
4.134 -(***********************)
4.135 -(* Everything together *)
4.136 -(***********************)
4.137 -
4.138 -lemmas compute_hol = compute_if compute_bool compute_pair compute_option compute_list compute_let
4.139 -
4.140 -ML {*
4.141 -signature ComputeHOL =
4.142 -sig
4.143 - val prep_thms : thm list -> thm list
4.144 - val to_meta_eq : thm -> thm
4.145 - val to_hol_eq : thm -> thm
4.146 - val symmetric : thm -> thm
4.147 - val trans : thm -> thm -> thm
4.148 -end
4.149 -
4.150 -structure ComputeHOL : ComputeHOL =
4.151 -struct
4.152 -
4.153 -local
4.154 -fun lhs_of eq = fst (Thm.dest_equals (cprop_of eq));
4.155 -in
4.156 -fun rewrite_conv [] ct = raise CTERM ("rewrite_conv", [ct])
4.157 - | rewrite_conv (eq :: eqs) ct =
4.158 - Thm.instantiate (Thm.match (lhs_of eq, ct)) eq
4.159 - handle Pattern.MATCH => rewrite_conv eqs ct;
4.160 -end
4.161 -
4.162 -val convert_conditions = Conv.fconv_rule (Conv.prems_conv ~1 (Conv.try_conv (rewrite_conv [@{thm "Trueprop_eq_eq"}])))
4.163 -
4.164 -val eq_th = @{thm "HOL.eq_reflection"}
4.165 -val meta_eq_trivial = @{thm "ComputeHOL.meta_eq_trivial"}
4.166 -val bool_to_true = @{thm "ComputeHOL.bool_to_true"}
4.167 -
4.168 -fun to_meta_eq th = eq_th OF [th] handle THM _ => meta_eq_trivial OF [th] handle THM _ => bool_to_true OF [th]
4.169 -
4.170 -fun to_hol_eq th = @{thm "meta_eq_imp_eq"} OF [th] handle THM _ => @{thm "eq_trivial"} OF [th]
4.171 -
4.172 -fun prep_thms ths = map (convert_conditions o to_meta_eq) ths
4.173 -
4.174 -fun symmetric th = @{thm "HOL.sym"} OF [th] handle THM _ => @{thm "Pure.symmetric"} OF [th]
4.175 -
4.176 -local
4.177 - val trans_HOL = @{thm "HOL.trans"}
4.178 - val trans_HOL_1 = @{thm "ComputeHOL.transmeta_1"}
4.179 - val trans_HOL_2 = @{thm "ComputeHOL.transmeta_2"}
4.180 - val trans_HOL_3 = @{thm "ComputeHOL.transmeta_3"}
4.181 - fun tr [] th1 th2 = trans_HOL OF [th1, th2]
4.182 - | tr (t::ts) th1 th2 = (t OF [th1, th2] handle THM _ => tr ts th1 th2)
4.183 -in
4.184 - fun trans th1 th2 = tr [trans_HOL, trans_HOL_1, trans_HOL_2, trans_HOL_3] th1 th2
4.185 -end
4.186 -
4.187 -end
4.188 -*}
4.189 -
4.190 -end
5.1 --- a/src/HOL/Matrix/ComputeNumeral.thy Sat Mar 17 12:26:19 2012 +0100
5.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
5.3 @@ -1,189 +0,0 @@
5.4 -theory ComputeNumeral
5.5 -imports ComputeHOL ComputeFloat
5.6 -begin
5.7 -
5.8 -(* normalization of bit strings *)
5.9 -lemmas bitnorm = normalize_bin_simps
5.10 -
5.11 -(* neg for bit strings *)
5.12 -lemma neg1: "neg Int.Pls = False" by (simp add: Int.Pls_def)
5.13 -lemma neg2: "neg Int.Min = True" apply (subst Int.Min_def) by auto
5.14 -lemma neg3: "neg (Int.Bit0 x) = neg x" apply (simp add: neg_def) apply (subst Bit0_def) by auto
5.15 -lemma neg4: "neg (Int.Bit1 x) = neg x" apply (simp add: neg_def) apply (subst Bit1_def) by auto
5.16 -lemmas bitneg = neg1 neg2 neg3 neg4
5.17 -
5.18 -(* iszero for bit strings *)
5.19 -lemma iszero1: "iszero Int.Pls = True" by (simp add: Int.Pls_def iszero_def)
5.20 -lemma iszero2: "iszero Int.Min = False" apply (subst Int.Min_def) apply (subst iszero_def) by simp
5.21 -lemma iszero3: "iszero (Int.Bit0 x) = iszero x" apply (subst Int.Bit0_def) apply (subst iszero_def)+ by auto
5.22 -lemma iszero4: "iszero (Int.Bit1 x) = False" apply (subst Int.Bit1_def) apply (subst iszero_def)+ apply simp by arith
5.23 -lemmas bitiszero = iszero1 iszero2 iszero3 iszero4
5.24 -
5.25 -(* lezero for bit strings *)
5.26 -definition "lezero x \<longleftrightarrow> x \<le> 0"
5.27 -lemma lezero1: "lezero Int.Pls = True" unfolding Int.Pls_def lezero_def by auto
5.28 -lemma lezero2: "lezero Int.Min = True" unfolding Int.Min_def lezero_def by auto
5.29 -lemma lezero3: "lezero (Int.Bit0 x) = lezero x" unfolding Int.Bit0_def lezero_def by auto
5.30 -lemma lezero4: "lezero (Int.Bit1 x) = neg x" unfolding Int.Bit1_def lezero_def neg_def by auto
5.31 -lemmas bitlezero = lezero1 lezero2 lezero3 lezero4
5.32 -
5.33 -(* equality for bit strings *)
5.34 -lemmas biteq = eq_bin_simps
5.35 -
5.36 -(* x < y for bit strings *)
5.37 -lemmas bitless = less_bin_simps
5.38 -
5.39 -(* x \<le> y for bit strings *)
5.40 -lemmas bitle = le_bin_simps
5.41 -
5.42 -(* succ for bit strings *)
5.43 -lemmas bitsucc = succ_bin_simps
5.44 -
5.45 -(* pred for bit strings *)
5.46 -lemmas bitpred = pred_bin_simps
5.47 -
5.48 -(* unary minus for bit strings *)
5.49 -lemmas bituminus = minus_bin_simps
5.50 -
5.51 -(* addition for bit strings *)
5.52 -lemmas bitadd = add_bin_simps
5.53 -
5.54 -(* multiplication for bit strings *)
5.55 -lemma mult_Pls_right: "x * Int.Pls = Int.Pls" by (simp add: Pls_def)
5.56 -lemma mult_Min_right: "x * Int.Min = - x" by (subst mult_commute) simp
5.57 -lemma multb0x: "(Int.Bit0 x) * y = Int.Bit0 (x * y)" by (rule mult_Bit0)
5.58 -lemma multxb0: "x * (Int.Bit0 y) = Int.Bit0 (x * y)" unfolding Bit0_def by simp
5.59 -lemma multb1: "(Int.Bit1 x) * (Int.Bit1 y) = Int.Bit1 (Int.Bit0 (x * y) + x + y)"
5.60 - unfolding Bit0_def Bit1_def by (simp add: algebra_simps)
5.61 -lemmas bitmul = mult_Pls mult_Min mult_Pls_right mult_Min_right multb0x multxb0 multb1
5.62 -
5.63 -lemmas bitarith = bitnorm bitiszero bitneg bitlezero biteq bitless bitle bitsucc bitpred bituminus bitadd bitmul
5.64 -
5.65 -definition "nat_norm_number_of (x::nat) = x"
5.66 -
5.67 -lemma nat_norm_number_of: "nat_norm_number_of (number_of w) = (if lezero w then 0 else number_of w)"
5.68 - apply (simp add: nat_norm_number_of_def)
5.69 - unfolding lezero_def iszero_def neg_def
5.70 - apply (simp add: numeral_simps)
5.71 - done
5.72 -
5.73 -(* Normalization of nat literals *)
5.74 -lemma natnorm0: "(0::nat) = number_of (Int.Pls)" by auto
5.75 -lemma natnorm1: "(1 :: nat) = number_of (Int.Bit1 Int.Pls)" by auto
5.76 -lemmas natnorm = natnorm0 natnorm1 nat_norm_number_of
5.77 -
5.78 -(* Suc *)
5.79 -lemma natsuc: "Suc (number_of x) = (if neg x then 1 else number_of (Int.succ x))" by (auto simp add: number_of_is_id)
5.80 -
5.81 -(* Addition for nat *)
5.82 -lemma natadd: "number_of x + ((number_of y)::nat) = (if neg x then (number_of y) else (if neg y then number_of x else (number_of (x + y))))"
5.83 - unfolding nat_number_of_def number_of_is_id neg_def
5.84 - by auto
5.85 -
5.86 -(* Subtraction for nat *)
5.87 -lemma natsub: "(number_of x) - ((number_of y)::nat) =
5.88 - (if neg x then 0 else (if neg y then number_of x else (nat_norm_number_of (number_of (x + (- y))))))"
5.89 - unfolding nat_norm_number_of
5.90 - by (auto simp add: number_of_is_id neg_def lezero_def iszero_def Let_def nat_number_of_def)
5.91 -
5.92 -(* Multiplication for nat *)
5.93 -lemma natmul: "(number_of x) * ((number_of y)::nat) =
5.94 - (if neg x then 0 else (if neg y then 0 else number_of (x * y)))"
5.95 - unfolding nat_number_of_def number_of_is_id neg_def
5.96 - by (simp add: nat_mult_distrib)
5.97 -
5.98 -lemma nateq: "(((number_of x)::nat) = (number_of y)) = ((lezero x \<and> lezero y) \<or> (x = y))"
5.99 - by (auto simp add: iszero_def lezero_def neg_def number_of_is_id)
5.100 -
5.101 -lemma natless: "(((number_of x)::nat) < (number_of y)) = ((x < y) \<and> (\<not> (lezero y)))"
5.102 - by (simp add: lezero_def numeral_simps not_le)
5.103 -
5.104 -lemma natle: "(((number_of x)::nat) \<le> (number_of y)) = (y < x \<longrightarrow> lezero x)"
5.105 - by (auto simp add: number_of_is_id lezero_def nat_number_of_def)
5.106 -
5.107 -fun natfac :: "nat \<Rightarrow> nat"
5.108 - where "natfac n = (if n = 0 then 1 else n * (natfac (n - 1)))"
5.109 -
5.110 -lemmas compute_natarith = bitarith natnorm natsuc natadd natsub natmul nateq natless natle natfac.simps
5.111 -
5.112 -lemma number_eq: "(((number_of x)::'a::{number_ring, linordered_idom}) = (number_of y)) = (x = y)"
5.113 - unfolding number_of_eq
5.114 - apply simp
5.115 - done
5.116 -
5.117 -lemma number_le: "(((number_of x)::'a::{number_ring, linordered_idom}) \<le> (number_of y)) = (x \<le> y)"
5.118 - unfolding number_of_eq
5.119 - apply simp
5.120 - done
5.121 -
5.122 -lemma number_less: "(((number_of x)::'a::{number_ring, linordered_idom}) < (number_of y)) = (x < y)"
5.123 - unfolding number_of_eq
5.124 - apply simp
5.125 - done
5.126 -
5.127 -lemma number_diff: "((number_of x)::'a::{number_ring, linordered_idom}) - number_of y = number_of (x + (- y))"
5.128 - apply (subst diff_number_of_eq)
5.129 - apply simp
5.130 - done
5.131 -
5.132 -lemmas number_norm = number_of_Pls[symmetric] numeral_1_eq_1[symmetric]
5.133 -
5.134 -lemmas compute_numberarith = number_of_minus[symmetric] number_of_add[symmetric] number_diff number_of_mult[symmetric] number_norm number_eq number_le number_less
5.135 -
5.136 -lemma compute_real_of_nat_number_of: "real ((number_of v)::nat) = (if neg v then 0 else number_of v)"
5.137 - by (simp only: real_of_nat_number_of number_of_is_id)
5.138 -
5.139 -lemma compute_nat_of_int_number_of: "nat ((number_of v)::int) = (number_of v)"
5.140 - by simp
5.141 -
5.142 -lemmas compute_num_conversions = compute_real_of_nat_number_of compute_nat_of_int_number_of real_number_of
5.143 -
5.144 -lemmas zpowerarith = zpower_number_of_even
5.145 - zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
5.146 - zpower_Pls zpower_Min
5.147 -
5.148 -(* div, mod *)
5.149 -
5.150 -lemma adjust: "adjust b (q, r) = (if 0 \<le> r - b then (2 * q + 1, r - b) else (2 * q, r))"
5.151 - by (auto simp only: adjust_def)
5.152 -
5.153 -lemma divmod: "divmod_int a b = (if 0\<le>a then
5.154 - if 0\<le>b then posDivAlg a b
5.155 - else if a=0 then (0, 0)
5.156 - else apsnd uminus (negDivAlg (-a) (-b))
5.157 - else
5.158 - if 0<b then negDivAlg a b
5.159 - else apsnd uminus (posDivAlg (-a) (-b)))"
5.160 - by (auto simp only: divmod_int_def)
5.161 -
5.162 -lemmas compute_div_mod = div_int_def mod_int_def divmod adjust apsnd_def map_pair_def posDivAlg.simps negDivAlg.simps
5.163 -
5.164 -
5.165 -
5.166 -(* collecting all the theorems *)
5.167 -
5.168 -lemma even_Pls: "even (Int.Pls) = True"
5.169 - apply (unfold Pls_def even_def)
5.170 - by simp
5.171 -
5.172 -lemma even_Min: "even (Int.Min) = False"
5.173 - apply (unfold Min_def even_def)
5.174 - by simp
5.175 -
5.176 -lemma even_B0: "even (Int.Bit0 x) = True"
5.177 - apply (unfold Bit0_def)
5.178 - by simp
5.179 -
5.180 -lemma even_B1: "even (Int.Bit1 x) = False"
5.181 - apply (unfold Bit1_def)
5.182 - by simp
5.183 -
5.184 -lemma even_number_of: "even ((number_of w)::int) = even w"
5.185 - by (simp only: number_of_is_id)
5.186 -
5.187 -lemmas compute_even = even_Pls even_Min even_B0 even_B1 even_number_of
5.188 -
5.189 -lemmas compute_numeral = compute_if compute_let compute_pair compute_bool
5.190 - compute_natarith compute_numberarith max_def min_def compute_num_conversions zpowerarith compute_div_mod compute_even
5.191 -
5.192 -end
6.1 --- a/src/HOL/Matrix/Compute_Oracle/Compute_Oracle.thy Sat Mar 17 12:26:19 2012 +0100
6.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
6.3 @@ -1,11 +0,0 @@
6.4 -(* Title: HOL/Matrix/Compute_Oracle/Compute_Oracle.thy
6.5 - Author: Steven Obua, TU Munich
6.6 -
6.7 -Steven Obua's evaluator.
6.8 -*)
6.9 -
6.10 -theory Compute_Oracle imports HOL
6.11 -uses "am.ML" "am_compiler.ML" "am_interpreter.ML" "am_ghc.ML" "am_sml.ML" "report.ML" "compute.ML" "linker.ML"
6.12 -begin
6.13 -
6.14 -end
6.15 \ No newline at end of file
7.1 --- a/src/HOL/Matrix/Compute_Oracle/am.ML Sat Mar 17 12:26:19 2012 +0100
7.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3 @@ -1,71 +0,0 @@
7.4 -signature ABSTRACT_MACHINE =
7.5 -sig
7.6 -
7.7 -datatype term = Var of int | Const of int | App of term * term | Abs of term | Computed of term
7.8 -
7.9 -datatype pattern = PVar | PConst of int * (pattern list)
7.10 -
7.11 -datatype guard = Guard of term * term
7.12 -
7.13 -type program
7.14 -
7.15 -exception Compile of string;
7.16 -
7.17 -(* The de-Bruijn index 0 occurring on the right hand side refers to the LAST pattern variable, when traversing the pattern from left to right,
7.18 - 1 to the second last, and so on. *)
7.19 -val compile : (guard list * pattern * term) list -> program
7.20 -
7.21 -exception Run of string;
7.22 -val run : program -> term -> term
7.23 -
7.24 -(* Utilities *)
7.25 -
7.26 -val check_freevars : int -> term -> bool
7.27 -val forall_consts : (int -> bool) -> term -> bool
7.28 -val closed : term -> bool
7.29 -val erase_Computed : term -> term
7.30 -
7.31 -end
7.32 -
7.33 -structure AbstractMachine : ABSTRACT_MACHINE =
7.34 -struct
7.35 -
7.36 -datatype term = Var of int | Const of int | App of term * term | Abs of term | Computed of term
7.37 -
7.38 -datatype pattern = PVar | PConst of int * (pattern list)
7.39 -
7.40 -datatype guard = Guard of term * term
7.41 -
7.42 -type program = unit
7.43 -
7.44 -exception Compile of string;
7.45 -
7.46 -fun erase_Computed (Computed t) = erase_Computed t
7.47 - | erase_Computed (App (t1, t2)) = App (erase_Computed t1, erase_Computed t2)
7.48 - | erase_Computed (Abs t) = Abs (erase_Computed t)
7.49 - | erase_Computed t = t
7.50 -
7.51 -(*Returns true iff at most 0 .. (free-1) occur unbound. therefore
7.52 - check_freevars 0 t iff t is closed*)
7.53 -fun check_freevars free (Var x) = x < free
7.54 - | check_freevars free (Const _) = true
7.55 - | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v
7.56 - | check_freevars free (Abs m) = check_freevars (free+1) m
7.57 - | check_freevars free (Computed t) = check_freevars free t
7.58 -
7.59 -fun forall_consts pred (Const c) = pred c
7.60 - | forall_consts pred (Var _) = true
7.61 - | forall_consts pred (App (u,v)) = forall_consts pred u
7.62 - andalso forall_consts pred v
7.63 - | forall_consts pred (Abs m) = forall_consts pred m
7.64 - | forall_consts pred (Computed t) = forall_consts pred t
7.65 -
7.66 -fun closed t = check_freevars 0 t
7.67 -
7.68 -fun compile _ = raise Compile "abstract machine stub"
7.69 -
7.70 -exception Run of string;
7.71 -
7.72 -fun run _ _ = raise Run "abstract machine stub"
7.73 -
7.74 -end
8.1 --- a/src/HOL/Matrix/Compute_Oracle/am_compiler.ML Sat Mar 17 12:26:19 2012 +0100
8.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
8.3 @@ -1,208 +0,0 @@
8.4 -(* Title: HOL/Matrix/Compute_Oracle/am_compiler.ML
8.5 - Author: Steven Obua
8.6 -*)
8.7 -
8.8 -signature COMPILING_AM =
8.9 -sig
8.10 - include ABSTRACT_MACHINE
8.11 -
8.12 - val set_compiled_rewriter : (term -> term) -> unit
8.13 - val list_nth : 'a list * int -> 'a
8.14 - val list_map : ('a -> 'b) -> 'a list -> 'b list
8.15 -end
8.16 -
8.17 -structure AM_Compiler : COMPILING_AM = struct
8.18 -
8.19 -val list_nth = List.nth;
8.20 -val list_map = map;
8.21 -
8.22 -open AbstractMachine;
8.23 -
8.24 -val compiled_rewriter = Unsynchronized.ref (NONE:(term -> term)Option.option)
8.25 -
8.26 -fun set_compiled_rewriter r = (compiled_rewriter := SOME r)
8.27 -
8.28 -type program = (term -> term)
8.29 -
8.30 -fun count_patternvars PVar = 1
8.31 - | count_patternvars (PConst (_, ps)) =
8.32 - List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
8.33 -
8.34 -fun print_rule (p, t) =
8.35 - let
8.36 - fun str x = string_of_int x
8.37 - fun print_pattern n PVar = (n+1, "x"^(str n))
8.38 - | print_pattern n (PConst (c, [])) = (n, "c"^(str c))
8.39 - | print_pattern n (PConst (c, args)) =
8.40 - let
8.41 - val h = print_pattern n (PConst (c,[]))
8.42 - in
8.43 - print_pattern_list h args
8.44 - end
8.45 - and print_pattern_list r [] = r
8.46 - | print_pattern_list (n, p) (t::ts) =
8.47 - let
8.48 - val (n, t) = print_pattern n t
8.49 - in
8.50 - print_pattern_list (n, "App ("^p^", "^t^")") ts
8.51 - end
8.52 -
8.53 - val (n, pattern) = print_pattern 0 p
8.54 - val pattern =
8.55 - if exists_string Symbol.is_ascii_blank pattern then "(" ^ pattern ^")"
8.56 - else pattern
8.57 -
8.58 - fun print_term d (Var x) = "Var " ^ str x
8.59 - | print_term d (Const c) = "c" ^ str c
8.60 - | print_term d (App (a,b)) = "App (" ^ print_term d a ^ ", " ^ print_term d b ^ ")"
8.61 - | print_term d (Abs c) = "Abs (" ^ print_term (d + 1) c ^ ")"
8.62 - | print_term d (Computed c) = print_term d c
8.63 -
8.64 - fun listvars n = if n = 0 then "x0" else "x"^(str n)^", "^(listvars (n-1))
8.65 -
8.66 - val term = print_term 0 t
8.67 - val term =
8.68 - if n > 0 then "Closure (["^(listvars (n-1))^"], "^term^")"
8.69 - else "Closure ([], "^term^")"
8.70 -
8.71 - in
8.72 - " | weak_reduce (false, stack, "^pattern^") = Continue (false, stack, "^term^")"
8.73 - end
8.74 -
8.75 -fun constants_of PVar = []
8.76 - | constants_of (PConst (c, ps)) = c :: maps constants_of ps
8.77 -
8.78 -fun constants_of_term (Var _) = []
8.79 - | constants_of_term (Abs m) = constants_of_term m
8.80 - | constants_of_term (App (a,b)) = (constants_of_term a)@(constants_of_term b)
8.81 - | constants_of_term (Const c) = [c]
8.82 - | constants_of_term (Computed c) = constants_of_term c
8.83 -
8.84 -fun load_rules sname name prog =
8.85 - let
8.86 - val buffer = Unsynchronized.ref ""
8.87 - fun write s = (buffer := (!buffer)^s)
8.88 - fun writeln s = (write s; write "\n")
8.89 - fun writelist [] = ()
8.90 - | writelist (s::ss) = (writeln s; writelist ss)
8.91 - fun str i = string_of_int i
8.92 - val _ = writelist [
8.93 - "structure "^name^" = struct",
8.94 - "",
8.95 - "datatype term = Dummy | App of term * term | Abs of term | Var of int | Const of int | Closure of term list * term"]
8.96 - val constants = distinct (op =) (maps (fn (p, r) => ((constants_of p)@(constants_of_term r))) prog)
8.97 - val _ = map (fn x => write (" | c"^(str x))) constants
8.98 - val _ = writelist [
8.99 - "",
8.100 - "datatype stack = SEmpty | SAppL of term * stack | SAppR of term * stack | SAbs of stack",
8.101 - "",
8.102 - "type state = bool * stack * term",
8.103 - "",
8.104 - "datatype loopstate = Continue of state | Stop of stack * term",
8.105 - "",
8.106 - "fun proj_C (Continue s) = s",
8.107 - " | proj_C _ = raise Match",
8.108 - "",
8.109 - "fun proj_S (Stop s) = s",
8.110 - " | proj_S _ = raise Match",
8.111 - "",
8.112 - "fun cont (Continue _) = true",
8.113 - " | cont _ = false",
8.114 - "",
8.115 - "fun do_reduction reduce p =",
8.116 - " let",
8.117 - " val s = Unsynchronized.ref (Continue p)",
8.118 - " val _ = while cont (!s) do (s := reduce (proj_C (!s)))",
8.119 - " in",
8.120 - " proj_S (!s)",
8.121 - " end",
8.122 - ""]
8.123 -
8.124 - val _ = writelist [
8.125 - "fun weak_reduce (false, stack, Closure (e, App (a, b))) = Continue (false, SAppL (Closure (e, b), stack), Closure (e, a))",
8.126 - " | weak_reduce (false, SAppL (b, stack), Closure (e, Abs m)) = Continue (false, stack, Closure (b::e, m))",
8.127 - " | weak_reduce (false, stack, c as Closure (e, Abs m)) = Continue (true, stack, c)",
8.128 - " | weak_reduce (false, stack, Closure (e, Var n)) = Continue (false, stack, case "^sname^".list_nth (e, n) of Dummy => Var n | r => r)",
8.129 - " | weak_reduce (false, stack, Closure (e, c)) = Continue (false, stack, c)"]
8.130 - val _ = writelist (map print_rule prog)
8.131 - val _ = writelist [
8.132 - " | weak_reduce (false, stack, clos) = Continue (true, stack, clos)",
8.133 - " | weak_reduce (true, SAppR (a, stack), b) = Continue (false, stack, App (a,b))",
8.134 - " | weak_reduce (true, s as (SAppL (b, stack)), a) = Continue (false, SAppR (a, stack), b)",
8.135 - " | weak_reduce (true, stack, c) = Stop (stack, c)",
8.136 - "",
8.137 - "fun strong_reduce (false, stack, Closure (e, Abs m)) =",
8.138 - " let",
8.139 - " val (stack', wnf) = do_reduction weak_reduce (false, SEmpty, Closure (Dummy::e, m))",
8.140 - " in",
8.141 - " case stack' of",
8.142 - " SEmpty => Continue (false, SAbs stack, wnf)",
8.143 - " | _ => raise ("^sname^".Run \"internal error in strong: weak failed\")",
8.144 - " end",
8.145 - " | strong_reduce (false, stack, clos as (App (u, v))) = Continue (false, SAppL (v, stack), u)",
8.146 - " | strong_reduce (false, stack, clos) = Continue (true, stack, clos)",
8.147 - " | strong_reduce (true, SAbs stack, m) = Continue (false, stack, Abs m)",
8.148 - " | strong_reduce (true, SAppL (b, stack), a) = Continue (false, SAppR (a, stack), b)",
8.149 - " | strong_reduce (true, SAppR (a, stack), b) = Continue (true, stack, App (a, b))",
8.150 - " | strong_reduce (true, stack, clos) = Stop (stack, clos)",
8.151 - ""]
8.152 -
8.153 - val ic = "(case c of "^(implode (map (fn c => (str c)^" => c"^(str c)^" | ") constants))^" _ => Const c)"
8.154 - val _ = writelist [
8.155 - "fun importTerm ("^sname^".Var x) = Var x",
8.156 - " | importTerm ("^sname^".Const c) = "^ic,
8.157 - " | importTerm ("^sname^".App (a, b)) = App (importTerm a, importTerm b)",
8.158 - " | importTerm ("^sname^".Abs m) = Abs (importTerm m)",
8.159 - ""]
8.160 -
8.161 - fun ec c = " | exportTerm c"^(str c)^" = "^sname^".Const "^(str c)
8.162 - val _ = writelist [
8.163 - "fun exportTerm (Var x) = "^sname^".Var x",
8.164 - " | exportTerm (Const c) = "^sname^".Const c",
8.165 - " | exportTerm (App (a,b)) = "^sname^".App (exportTerm a, exportTerm b)",
8.166 - " | exportTerm (Abs m) = "^sname^".Abs (exportTerm m)",
8.167 - " | exportTerm (Closure (closlist, clos)) = raise ("^sname^".Run \"internal error, cannot export Closure\")",
8.168 - " | exportTerm Dummy = raise ("^sname^".Run \"internal error, cannot export Dummy\")"]
8.169 - val _ = writelist (map ec constants)
8.170 -
8.171 - val _ = writelist [
8.172 - "",
8.173 - "fun rewrite t = ",
8.174 - " let",
8.175 - " val (stack, wnf) = do_reduction weak_reduce (false, SEmpty, Closure ([], importTerm t))",
8.176 - " in",
8.177 - " case stack of ",
8.178 - " SEmpty => (case do_reduction strong_reduce (false, SEmpty, wnf) of",
8.179 - " (SEmpty, snf) => exportTerm snf",
8.180 - " | _ => raise ("^sname^".Run \"internal error in rewrite: strong failed\"))",
8.181 - " | _ => (raise ("^sname^".Run \"internal error in rewrite: weak failed\"))",
8.182 - " end",
8.183 - "",
8.184 - "val _ = "^sname^".set_compiled_rewriter rewrite",
8.185 - "",
8.186 - "end;"]
8.187 -
8.188 - in
8.189 - compiled_rewriter := NONE;
8.190 - use_text ML_Env.local_context (1, "") false (!buffer);
8.191 - case !compiled_rewriter of
8.192 - NONE => raise (Compile "cannot communicate with compiled function")
8.193 - | SOME r => (compiled_rewriter := NONE; r)
8.194 - end
8.195 -
8.196 -fun compile eqs =
8.197 - let
8.198 - val _ = if exists (fn (a,_,_) => not (null a)) eqs then raise Compile ("cannot deal with guards") else ()
8.199 - val eqs = map (fn (_,b,c) => (b,c)) eqs
8.200 - fun check (p, r) = if check_freevars (count_patternvars p) r then () else raise Compile ("unbound variables in rule")
8.201 - val _ = map (fn (p, r) =>
8.202 - (check (p, r);
8.203 - case p of PVar => raise (Compile "pattern is just a variable") | _ => ())) eqs
8.204 - in
8.205 - load_rules "AM_Compiler" "AM_compiled_code" eqs
8.206 - end
8.207 -
8.208 -fun run prog t = prog t
8.209 -
8.210 -end
8.211 -
9.1 --- a/src/HOL/Matrix/Compute_Oracle/am_ghc.ML Sat Mar 17 12:26:19 2012 +0100
9.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
9.3 @@ -1,324 +0,0 @@
9.4 -(* Title: HOL/Matrix/Compute_Oracle/am_ghc.ML
9.5 - Author: Steven Obua
9.6 -*)
9.7 -
9.8 -structure AM_GHC : ABSTRACT_MACHINE =
9.9 -struct
9.10 -
9.11 -open AbstractMachine;
9.12 -
9.13 -type program = string * string * (int Inttab.table)
9.14 -
9.15 -fun count_patternvars PVar = 1
9.16 - | count_patternvars (PConst (_, ps)) =
9.17 - List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
9.18 -
9.19 -fun update_arity arity code a =
9.20 - (case Inttab.lookup arity code of
9.21 - NONE => Inttab.update_new (code, a) arity
9.22 - | SOME (a': int) => if a > a' then Inttab.update (code, a) arity else arity)
9.23 -
9.24 -(* We have to find out the maximal arity of each constant *)
9.25 -fun collect_pattern_arity PVar arity = arity
9.26 - | collect_pattern_arity (PConst (c, args)) arity = fold collect_pattern_arity args (update_arity arity c (length args))
9.27 -
9.28 -local
9.29 -fun collect applevel (Var _) arity = arity
9.30 - | collect applevel (Const c) arity = update_arity arity c applevel
9.31 - | collect applevel (Abs m) arity = collect 0 m arity
9.32 - | collect applevel (App (a,b)) arity = collect 0 b (collect (applevel + 1) a arity)
9.33 -in
9.34 -fun collect_term_arity t arity = collect 0 t arity
9.35 -end
9.36 -
9.37 -fun nlift level n (Var m) = if m < level then Var m else Var (m+n)
9.38 - | nlift level n (Const c) = Const c
9.39 - | nlift level n (App (a,b)) = App (nlift level n a, nlift level n b)
9.40 - | nlift level n (Abs b) = Abs (nlift (level+1) n b)
9.41 -
9.42 -fun rep n x = if n = 0 then [] else x::(rep (n-1) x)
9.43 -
9.44 -fun adjust_rules rules =
9.45 - let
9.46 - val arity = fold (fn (p, t) => fn arity => collect_term_arity t (collect_pattern_arity p arity)) rules Inttab.empty
9.47 - fun arity_of c = the (Inttab.lookup arity c)
9.48 - fun adjust_pattern PVar = PVar
9.49 - | adjust_pattern (C as PConst (c, args)) = if (length args <> arity_of c) then raise Compile ("Constant inside pattern must have maximal arity") else C
9.50 - fun adjust_rule (PVar, _) = raise Compile ("pattern may not be a variable")
9.51 - | adjust_rule (rule as (p as PConst (c, args),t)) =
9.52 - let
9.53 - val _ = if not (check_freevars (count_patternvars p) t) then raise Compile ("unbound variables on right hand side") else ()
9.54 - val args = map adjust_pattern args
9.55 - val len = length args
9.56 - val arity = arity_of c
9.57 - fun lift level n (Var m) = if m < level then Var m else Var (m+n)
9.58 - | lift level n (Const c) = Const c
9.59 - | lift level n (App (a,b)) = App (lift level n a, lift level n b)
9.60 - | lift level n (Abs b) = Abs (lift (level+1) n b)
9.61 - val lift = lift 0
9.62 - fun adjust_term n t = if n=0 then t else adjust_term (n-1) (App (t, Var (n-1)))
9.63 - in
9.64 - if len = arity then
9.65 - rule
9.66 - else if arity >= len then
9.67 - (PConst (c, args @ (rep (arity-len) PVar)), adjust_term (arity-len) (lift (arity-len) t))
9.68 - else (raise Compile "internal error in adjust_rule")
9.69 - end
9.70 - in
9.71 - (arity, map adjust_rule rules)
9.72 - end
9.73 -
9.74 -fun print_term arity_of n =
9.75 -let
9.76 - fun str x = string_of_int x
9.77 - fun protect_blank s = if exists_string Symbol.is_ascii_blank s then "(" ^ s ^")" else s
9.78 -
9.79 - fun print_apps d f [] = f
9.80 - | print_apps d f (a::args) = print_apps d ("app "^(protect_blank f)^" "^(protect_blank (print_term d a))) args
9.81 - and print_call d (App (a, b)) args = print_call d a (b::args)
9.82 - | print_call d (Const c) args =
9.83 - (case arity_of c of
9.84 - NONE => print_apps d ("Const "^(str c)) args
9.85 - | SOME a =>
9.86 - let
9.87 - val len = length args
9.88 - in
9.89 - if a <= len then
9.90 - let
9.91 - val s = "c"^(str c)^(implode (map (fn t => " "^(protect_blank (print_term d t))) (List.take (args, a))))
9.92 - in
9.93 - print_apps d s (List.drop (args, a))
9.94 - end
9.95 - else
9.96 - let
9.97 - fun mk_apps n t = if n = 0 then t else mk_apps (n-1) (App (t, Var (n-1)))
9.98 - fun mk_lambdas n t = if n = 0 then t else mk_lambdas (n-1) (Abs t)
9.99 - fun append_args [] t = t
9.100 - | append_args (c::cs) t = append_args cs (App (t, c))
9.101 - in
9.102 - print_term d (mk_lambdas (a-len) (mk_apps (a-len) (nlift 0 (a-len) (append_args args (Const c)))))
9.103 - end
9.104 - end)
9.105 - | print_call d t args = print_apps d (print_term d t) args
9.106 - and print_term d (Var x) = if x < d then "b"^(str (d-x-1)) else "x"^(str (n-(x-d)-1))
9.107 - | print_term d (Abs c) = "Abs (\\b"^(str d)^" -> "^(print_term (d + 1) c)^")"
9.108 - | print_term d t = print_call d t []
9.109 -in
9.110 - print_term 0
9.111 -end
9.112 -
9.113 -fun print_rule arity_of (p, t) =
9.114 - let
9.115 - fun str x = string_of_int x
9.116 - fun print_pattern top n PVar = (n+1, "x"^(str n))
9.117 - | print_pattern top n (PConst (c, [])) = (n, (if top then "c" else "C")^(str c))
9.118 - | print_pattern top n (PConst (c, args)) =
9.119 - let
9.120 - val (n,s) = print_pattern_list (n, (if top then "c" else "C")^(str c)) args
9.121 - in
9.122 - (n, if top then s else "("^s^")")
9.123 - end
9.124 - and print_pattern_list r [] = r
9.125 - | print_pattern_list (n, p) (t::ts) =
9.126 - let
9.127 - val (n, t) = print_pattern false n t
9.128 - in
9.129 - print_pattern_list (n, p^" "^t) ts
9.130 - end
9.131 - val (n, pattern) = print_pattern true 0 p
9.132 - in
9.133 - pattern^" = "^(print_term arity_of n t)
9.134 - end
9.135 -
9.136 -fun group_rules rules =
9.137 - let
9.138 - fun add_rule (r as (PConst (c,_), _)) groups =
9.139 - let
9.140 - val rs = (case Inttab.lookup groups c of NONE => [] | SOME rs => rs)
9.141 - in
9.142 - Inttab.update (c, r::rs) groups
9.143 - end
9.144 - | add_rule _ _ = raise Compile "internal error group_rules"
9.145 - in
9.146 - fold_rev add_rule rules Inttab.empty
9.147 - end
9.148 -
9.149 -fun haskell_prog name rules =
9.150 - let
9.151 - val buffer = Unsynchronized.ref ""
9.152 - fun write s = (buffer := (!buffer)^s)
9.153 - fun writeln s = (write s; write "\n")
9.154 - fun writelist [] = ()
9.155 - | writelist (s::ss) = (writeln s; writelist ss)
9.156 - fun str i = string_of_int i
9.157 - val (arity, rules) = adjust_rules rules
9.158 - val rules = group_rules rules
9.159 - val constants = Inttab.keys arity
9.160 - fun arity_of c = Inttab.lookup arity c
9.161 - fun rep_str s n = implode (rep n s)
9.162 - fun indexed s n = s^(str n)
9.163 - fun section n = if n = 0 then [] else (section (n-1))@[n-1]
9.164 - fun make_show c =
9.165 - let
9.166 - val args = section (the (arity_of c))
9.167 - in
9.168 - " show ("^(indexed "C" c)^(implode (map (indexed " a") args))^") = "
9.169 - ^"\""^(indexed "C" c)^"\""^(implode (map (fn a => "++(show "^(indexed "a" a)^")") args))
9.170 - end
9.171 - fun default_case c =
9.172 - let
9.173 - val args = implode (map (indexed " x") (section (the (arity_of c))))
9.174 - in
9.175 - (indexed "c" c)^args^" = "^(indexed "C" c)^args
9.176 - end
9.177 - val _ = writelist [
9.178 - "module "^name^" where",
9.179 - "",
9.180 - "data Term = Const Integer | App Term Term | Abs (Term -> Term)",
9.181 - " "^(implode (map (fn c => " | C"^(str c)^(rep_str " Term" (the (arity_of c)))) constants)),
9.182 - "",
9.183 - "instance Show Term where"]
9.184 - val _ = writelist (map make_show constants)
9.185 - val _ = writelist [
9.186 - " show (Const c) = \"c\"++(show c)",
9.187 - " show (App a b) = \"A\"++(show a)++(show b)",
9.188 - " show (Abs _) = \"L\"",
9.189 - ""]
9.190 - val _ = writelist [
9.191 - "app (Abs a) b = a b",
9.192 - "app a b = App a b",
9.193 - "",
9.194 - "calc s c = writeFile s (show c)",
9.195 - ""]
9.196 - fun list_group c = (writelist (case Inttab.lookup rules c of
9.197 - NONE => [default_case c, ""]
9.198 - | SOME (rs as ((PConst (_, []), _)::rs')) =>
9.199 - if not (null rs') then raise Compile "multiple declaration of constant"
9.200 - else (map (print_rule arity_of) rs) @ [""]
9.201 - | SOME rs => (map (print_rule arity_of) rs) @ [default_case c, ""]))
9.202 - val _ = map list_group constants
9.203 - in
9.204 - (arity, !buffer)
9.205 - end
9.206 -
9.207 -val guid_counter = Unsynchronized.ref 0
9.208 -fun get_guid () =
9.209 - let
9.210 - val c = !guid_counter
9.211 - val _ = guid_counter := !guid_counter + 1
9.212 - in
9.213 - string_of_int (Time.toMicroseconds (Time.now ())) ^ string_of_int c
9.214 - end
9.215 -
9.216 -fun tmp_file s = Path.implode (Path.expand (File.tmp_path (Path.basic s)));
9.217 -
9.218 -fun writeTextFile name s = File.write (Path.explode name) s
9.219 -
9.220 -fun fileExists name = ((OS.FileSys.fileSize name; true) handle OS.SysErr _ => false)
9.221 -
9.222 -fun compile eqs =
9.223 - let
9.224 - val _ = if exists (fn (a,_,_) => not (null a)) eqs then raise Compile ("cannot deal with guards") else ()
9.225 - val eqs = map (fn (_,b,c) => (b,c)) eqs
9.226 - val guid = get_guid ()
9.227 - val module = "AMGHC_Prog_"^guid
9.228 - val (arity, source) = haskell_prog module eqs
9.229 - val module_file = tmp_file (module^".hs")
9.230 - val object_file = tmp_file (module^".o")
9.231 - val _ = writeTextFile module_file source
9.232 - val _ = Isabelle_System.bash ("exec \"$ISABELLE_GHC\" -c " ^ module_file)
9.233 - val _ =
9.234 - if not (fileExists object_file) then
9.235 - raise Compile ("Failure compiling haskell code (ISABELLE_GHC='" ^ getenv "ISABELLE_GHC" ^ "')")
9.236 - else ()
9.237 - in
9.238 - (guid, module_file, arity)
9.239 - end
9.240 -
9.241 -fun readResultFile name = File.read (Path.explode name)
9.242 -
9.243 -fun parse_result arity_of result =
9.244 - let
9.245 - val result = String.explode result
9.246 - fun shift NONE x = SOME x
9.247 - | shift (SOME y) x = SOME (y*10 + x)
9.248 - fun parse_int' x (#"0"::rest) = parse_int' (shift x 0) rest
9.249 - | parse_int' x (#"1"::rest) = parse_int' (shift x 1) rest
9.250 - | parse_int' x (#"2"::rest) = parse_int' (shift x 2) rest
9.251 - | parse_int' x (#"3"::rest) = parse_int' (shift x 3) rest
9.252 - | parse_int' x (#"4"::rest) = parse_int' (shift x 4) rest
9.253 - | parse_int' x (#"5"::rest) = parse_int' (shift x 5) rest
9.254 - | parse_int' x (#"6"::rest) = parse_int' (shift x 6) rest
9.255 - | parse_int' x (#"7"::rest) = parse_int' (shift x 7) rest
9.256 - | parse_int' x (#"8"::rest) = parse_int' (shift x 8) rest
9.257 - | parse_int' x (#"9"::rest) = parse_int' (shift x 9) rest
9.258 - | parse_int' x rest = (x, rest)
9.259 - fun parse_int rest = parse_int' NONE rest
9.260 -
9.261 - fun parse (#"C"::rest) =
9.262 - (case parse_int rest of
9.263 - (SOME c, rest) =>
9.264 - let
9.265 - val (args, rest) = parse_list (the (arity_of c)) rest
9.266 - fun app_args [] t = t
9.267 - | app_args (x::xs) t = app_args xs (App (t, x))
9.268 - in
9.269 - (app_args args (Const c), rest)
9.270 - end
9.271 - | (NONE, _) => raise Run "parse C")
9.272 - | parse (#"c"::rest) =
9.273 - (case parse_int rest of
9.274 - (SOME c, rest) => (Const c, rest)
9.275 - | _ => raise Run "parse c")
9.276 - | parse (#"A"::rest) =
9.277 - let
9.278 - val (a, rest) = parse rest
9.279 - val (b, rest) = parse rest
9.280 - in
9.281 - (App (a,b), rest)
9.282 - end
9.283 - | parse (#"L"::_) = raise Run "there may be no abstraction in the result"
9.284 - | parse _ = raise Run "invalid result"
9.285 - and parse_list n rest =
9.286 - if n = 0 then
9.287 - ([], rest)
9.288 - else
9.289 - let
9.290 - val (x, rest) = parse rest
9.291 - val (xs, rest) = parse_list (n-1) rest
9.292 - in
9.293 - (x::xs, rest)
9.294 - end
9.295 - val (parsed, rest) = parse result
9.296 - fun is_blank (#" "::rest) = is_blank rest
9.297 - | is_blank (#"\n"::rest) = is_blank rest
9.298 - | is_blank [] = true
9.299 - | is_blank _ = false
9.300 - in
9.301 - if is_blank rest then parsed else raise Run "non-blank suffix in result file"
9.302 - end
9.303 -
9.304 -fun run (guid, module_file, arity) t =
9.305 - let
9.306 - val _ = if check_freevars 0 t then () else raise Run ("can only compute closed terms")
9.307 - fun arity_of c = Inttab.lookup arity c
9.308 - val callguid = get_guid()
9.309 - val module = "AMGHC_Prog_"^guid
9.310 - val call = module^"_Call_"^callguid
9.311 - val result_file = tmp_file (module^"_Result_"^callguid^".txt")
9.312 - val call_file = tmp_file (call^".hs")
9.313 - val term = print_term arity_of 0 t
9.314 - val call_source = "module "^call^" where\n\nimport "^module^"\n\ncall = "^module^".calc \""^result_file^"\" ("^term^")"
9.315 - val _ = writeTextFile call_file call_source
9.316 - val _ = Isabelle_System.bash ("exec \"$ISABELLE_GHC\" -e \""^call^".call\" "^module_file^" "^call_file)
9.317 - val result = readResultFile result_file handle IO.Io _ =>
9.318 - raise Run ("Failure running haskell compiler (ISABELLE_GHC='" ^ getenv "ISABELLE_GHC" ^ "')")
9.319 - val t' = parse_result arity_of result
9.320 - val _ = OS.FileSys.remove call_file
9.321 - val _ = OS.FileSys.remove result_file
9.322 - in
9.323 - t'
9.324 - end
9.325 -
9.326 -end
9.327 -
10.1 --- a/src/HOL/Matrix/Compute_Oracle/am_interpreter.ML Sat Mar 17 12:26:19 2012 +0100
10.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
10.3 @@ -1,211 +0,0 @@
10.4 -(* Title: HOL/Matrix/Compute_Oracle/am_interpreter.ML
10.5 - Author: Steven Obua
10.6 -*)
10.7 -
10.8 -signature AM_BARRAS =
10.9 -sig
10.10 - include ABSTRACT_MACHINE
10.11 - val max_reductions : int option Unsynchronized.ref
10.12 -end
10.13 -
10.14 -structure AM_Interpreter : AM_BARRAS = struct
10.15 -
10.16 -open AbstractMachine;
10.17 -
10.18 -datatype closure = CDummy | CVar of int | CConst of int
10.19 - | CApp of closure * closure | CAbs of closure
10.20 - | Closure of (closure list) * closure
10.21 -
10.22 -structure prog_struct = Table(type key = int*int val ord = prod_ord int_ord int_ord);
10.23 -
10.24 -datatype program = Program of ((pattern * closure * (closure*closure) list) list) prog_struct.table
10.25 -
10.26 -datatype stack = SEmpty | SAppL of closure * stack | SAppR of closure * stack | SAbs of stack
10.27 -
10.28 -fun clos_of_term (Var x) = CVar x
10.29 - | clos_of_term (Const c) = CConst c
10.30 - | clos_of_term (App (u, v)) = CApp (clos_of_term u, clos_of_term v)
10.31 - | clos_of_term (Abs u) = CAbs (clos_of_term u)
10.32 - | clos_of_term (Computed t) = clos_of_term t
10.33 -
10.34 -fun term_of_clos (CVar x) = Var x
10.35 - | term_of_clos (CConst c) = Const c
10.36 - | term_of_clos (CApp (u, v)) = App (term_of_clos u, term_of_clos v)
10.37 - | term_of_clos (CAbs u) = Abs (term_of_clos u)
10.38 - | term_of_clos (Closure _) = raise (Run "internal error: closure in normalized term found")
10.39 - | term_of_clos CDummy = raise (Run "internal error: dummy in normalized term found")
10.40 -
10.41 -fun resolve_closure closures (CVar x) = (case nth closures x of CDummy => CVar x | r => r)
10.42 - | resolve_closure closures (CConst c) = CConst c
10.43 - | resolve_closure closures (CApp (u, v)) = CApp (resolve_closure closures u, resolve_closure closures v)
10.44 - | resolve_closure closures (CAbs u) = CAbs (resolve_closure (CDummy::closures) u)
10.45 - | resolve_closure closures (CDummy) = raise (Run "internal error: resolve_closure applied to CDummy")
10.46 - | resolve_closure closures (Closure (e, u)) = resolve_closure e u
10.47 -
10.48 -fun resolve_closure' c = resolve_closure [] c
10.49 -
10.50 -fun resolve_stack tm SEmpty = tm
10.51 - | resolve_stack tm (SAppL (c, s)) = resolve_stack (CApp (tm, resolve_closure' c)) s
10.52 - | resolve_stack tm (SAppR (c, s)) = resolve_stack (CApp (resolve_closure' c, tm)) s
10.53 - | resolve_stack tm (SAbs s) = resolve_stack (CAbs tm) s
10.54 -
10.55 -fun resolve (stack, closure) =
10.56 - let
10.57 - val _ = writeln "start resolving"
10.58 - val t = resolve_stack (resolve_closure' closure) stack
10.59 - val _ = writeln "finished resolving"
10.60 - in
10.61 - t
10.62 - end
10.63 -
10.64 -fun strip_closure args (CApp (a,b)) = strip_closure (b::args) a
10.65 - | strip_closure args x = (x, args)
10.66 -
10.67 -fun len_head_of_closure n (CApp (a, _)) = len_head_of_closure (n+1) a
10.68 - | len_head_of_closure n x = (n, x)
10.69 -
10.70 -
10.71 -(* earlier occurrence of PVar corresponds to higher de Bruijn index *)
10.72 -fun pattern_match args PVar clos = SOME (clos::args)
10.73 - | pattern_match args (PConst (c, patterns)) clos =
10.74 - let
10.75 - val (f, closargs) = strip_closure [] clos
10.76 - in
10.77 - case f of
10.78 - CConst d =>
10.79 - if c = d then
10.80 - pattern_match_list args patterns closargs
10.81 - else
10.82 - NONE
10.83 - | _ => NONE
10.84 - end
10.85 -and pattern_match_list args [] [] = SOME args
10.86 - | pattern_match_list args (p::ps) (c::cs) =
10.87 - (case pattern_match args p c of
10.88 - NONE => NONE
10.89 - | SOME args => pattern_match_list args ps cs)
10.90 - | pattern_match_list _ _ _ = NONE
10.91 -
10.92 -fun count_patternvars PVar = 1
10.93 - | count_patternvars (PConst (_, ps)) = List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
10.94 -
10.95 -fun pattern_key (PConst (c, ps)) = (c, length ps)
10.96 - | pattern_key _ = raise (Compile "pattern reduces to variable")
10.97 -
10.98 -(*Returns true iff at most 0 .. (free-1) occur unbound. therefore
10.99 - check_freevars 0 t iff t is closed*)
10.100 -fun check_freevars free (Var x) = x < free
10.101 - | check_freevars free (Const _) = true
10.102 - | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v
10.103 - | check_freevars free (Abs m) = check_freevars (free+1) m
10.104 - | check_freevars free (Computed t) = check_freevars free t
10.105 -
10.106 -fun compile eqs =
10.107 - let
10.108 - fun check p r = if check_freevars p r then () else raise Compile ("unbound variables in rule")
10.109 - fun check_guard p (Guard (a,b)) = (check p a; check p b)
10.110 - fun clos_of_guard (Guard (a,b)) = (clos_of_term a, clos_of_term b)
10.111 - val eqs = map (fn (guards, p, r) => let val pcount = count_patternvars p val _ = map (check_guard pcount) (guards) val _ = check pcount r in
10.112 - (pattern_key p, (p, clos_of_term r, map clos_of_guard guards)) end) eqs
10.113 - fun merge (k, a) table = prog_struct.update (k, case prog_struct.lookup table k of NONE => [a] | SOME l => a::l) table
10.114 - val p = fold merge eqs prog_struct.empty
10.115 - in
10.116 - Program p
10.117 - end
10.118 -
10.119 -
10.120 -type state = bool * program * stack * closure
10.121 -
10.122 -datatype loopstate = Continue of state | Stop of stack * closure
10.123 -
10.124 -fun proj_C (Continue s) = s
10.125 - | proj_C _ = raise Match
10.126 -
10.127 -exception InterruptedExecution of stack * closure
10.128 -
10.129 -fun proj_S (Stop s) = s
10.130 - | proj_S (Continue (_,_,s,c)) = (s,c)
10.131 -
10.132 -fun cont (Continue _) = true
10.133 - | cont _ = false
10.134 -
10.135 -val max_reductions = Unsynchronized.ref (NONE : int option)
10.136 -
10.137 -fun do_reduction reduce p =
10.138 - let
10.139 - val s = Unsynchronized.ref (Continue p)
10.140 - val counter = Unsynchronized.ref 0
10.141 - val _ = case !max_reductions of
10.142 - NONE => while cont (!s) do (s := reduce (proj_C (!s)))
10.143 - | SOME m => while cont (!s) andalso (!counter < m) do (s := reduce (proj_C (!s)); counter := (!counter) + 1)
10.144 - in
10.145 - case !max_reductions of
10.146 - SOME m => if !counter >= m then raise InterruptedExecution (proj_S (!s)) else proj_S (!s)
10.147 - | NONE => proj_S (!s)
10.148 - end
10.149 -
10.150 -fun match_rules prog n [] clos = NONE
10.151 - | match_rules prog n ((p,eq,guards)::rs) clos =
10.152 - case pattern_match [] p clos of
10.153 - NONE => match_rules prog (n+1) rs clos
10.154 - | SOME args => if forall (guard_checks prog args) guards then SOME (Closure (args, eq)) else match_rules prog (n+1) rs clos
10.155 -and guard_checks prog args (a,b) = (simp prog (Closure (args, a)) = simp prog (Closure (args, b)))
10.156 -and match_closure (p as (Program prog)) clos =
10.157 - case len_head_of_closure 0 clos of
10.158 - (len, CConst c) =>
10.159 - (case prog_struct.lookup prog (c, len) of
10.160 - NONE => NONE
10.161 - | SOME rules => match_rules p 0 rules clos)
10.162 - | _ => NONE
10.163 -
10.164 -and weak_reduce (false, prog, stack, Closure (e, CApp (a, b))) = Continue (false, prog, SAppL (Closure (e, b), stack), Closure (e, a))
10.165 - | weak_reduce (false, prog, SAppL (b, stack), Closure (e, CAbs m)) = Continue (false, prog, stack, Closure (b::e, m))
10.166 - | weak_reduce (false, prog, stack, Closure (e, CVar n)) = Continue (false, prog, stack, case nth e n of CDummy => CVar n | r => r)
10.167 - | weak_reduce (false, prog, stack, Closure (_, c as CConst _)) = Continue (false, prog, stack, c)
10.168 - | weak_reduce (false, prog, stack, clos) =
10.169 - (case match_closure prog clos of
10.170 - NONE => Continue (true, prog, stack, clos)
10.171 - | SOME r => Continue (false, prog, stack, r))
10.172 - | weak_reduce (true, prog, SAppR (a, stack), b) = Continue (false, prog, stack, CApp (a,b))
10.173 - | weak_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
10.174 - | weak_reduce (true, prog, stack, c) = Stop (stack, c)
10.175 -
10.176 -and strong_reduce (false, prog, stack, Closure (e, CAbs m)) =
10.177 - (let
10.178 - val (stack', wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure (CDummy::e, m))
10.179 - in
10.180 - case stack' of
10.181 - SEmpty => Continue (false, prog, SAbs stack, wnf)
10.182 - | _ => raise (Run "internal error in strong: weak failed")
10.183 - end handle InterruptedExecution state => raise InterruptedExecution (stack, resolve state))
10.184 - | strong_reduce (false, prog, stack, CApp (u, v)) = Continue (false, prog, SAppL (v, stack), u)
10.185 - | strong_reduce (false, prog, stack, clos) = Continue (true, prog, stack, clos)
10.186 - | strong_reduce (true, prog, SAbs stack, m) = Continue (false, prog, stack, CAbs m)
10.187 - | strong_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
10.188 - | strong_reduce (true, prog, SAppR (a, stack), b) = Continue (true, prog, stack, CApp (a, b))
10.189 - | strong_reduce (true, prog, stack, clos) = Stop (stack, clos)
10.190 -
10.191 -and simp prog t =
10.192 - (let
10.193 - val (stack, wnf) = do_reduction weak_reduce (false, prog, SEmpty, t)
10.194 - in
10.195 - case stack of
10.196 - SEmpty => (case do_reduction strong_reduce (false, prog, SEmpty, wnf) of
10.197 - (SEmpty, snf) => snf
10.198 - | _ => raise (Run "internal error in run: strong failed"))
10.199 - | _ => raise (Run "internal error in run: weak failed")
10.200 - end handle InterruptedExecution state => resolve state)
10.201 -
10.202 -
10.203 -fun run prog t =
10.204 - (let
10.205 - val (stack, wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure ([], clos_of_term t))
10.206 - in
10.207 - case stack of
10.208 - SEmpty => (case do_reduction strong_reduce (false, prog, SEmpty, wnf) of
10.209 - (SEmpty, snf) => term_of_clos snf
10.210 - | _ => raise (Run "internal error in run: strong failed"))
10.211 - | _ => raise (Run "internal error in run: weak failed")
10.212 - end handle InterruptedExecution state => term_of_clos (resolve state))
10.213 -
10.214 -end
11.1 --- a/src/HOL/Matrix/Compute_Oracle/am_sml.ML Sat Mar 17 12:26:19 2012 +0100
11.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
11.3 @@ -1,517 +0,0 @@
11.4 -(* Title: HOL/Matrix/Compute_Oracle/am_sml.ML
11.5 - Author: Steven Obua
11.6 -
11.7 -TODO: "parameterless rewrite cannot be used in pattern": In a lot of
11.8 -cases it CAN be used, and these cases should be handled
11.9 -properly; right now, all cases raise an exception.
11.10 -*)
11.11 -
11.12 -signature AM_SML =
11.13 -sig
11.14 - include ABSTRACT_MACHINE
11.15 - val save_result : (string * term) -> unit
11.16 - val set_compiled_rewriter : (term -> term) -> unit
11.17 - val list_nth : 'a list * int -> 'a
11.18 - val dump_output : (string option) Unsynchronized.ref
11.19 -end
11.20 -
11.21 -structure AM_SML : AM_SML = struct
11.22 -
11.23 -open AbstractMachine;
11.24 -
11.25 -val dump_output = Unsynchronized.ref (NONE: string option)
11.26 -
11.27 -type program = term Inttab.table * (term -> term)
11.28 -
11.29 -val saved_result = Unsynchronized.ref (NONE:(string*term)option)
11.30 -
11.31 -fun save_result r = (saved_result := SOME r)
11.32 -
11.33 -val list_nth = List.nth
11.34 -
11.35 -val compiled_rewriter = Unsynchronized.ref (NONE:(term -> term)Option.option)
11.36 -
11.37 -fun set_compiled_rewriter r = (compiled_rewriter := SOME r)
11.38 -
11.39 -fun count_patternvars PVar = 1
11.40 - | count_patternvars (PConst (_, ps)) =
11.41 - List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
11.42 -
11.43 -fun update_arity arity code a =
11.44 - (case Inttab.lookup arity code of
11.45 - NONE => Inttab.update_new (code, a) arity
11.46 - | SOME (a': int) => if a > a' then Inttab.update (code, a) arity else arity)
11.47 -
11.48 -(* We have to find out the maximal arity of each constant *)
11.49 -fun collect_pattern_arity PVar arity = arity
11.50 - | collect_pattern_arity (PConst (c, args)) arity = fold collect_pattern_arity args (update_arity arity c (length args))
11.51 -
11.52 -(* We also need to find out the maximal toplevel arity of each function constant *)
11.53 -fun collect_pattern_toplevel_arity PVar arity = raise Compile "internal error: collect_pattern_toplevel_arity"
11.54 - | collect_pattern_toplevel_arity (PConst (c, args)) arity = update_arity arity c (length args)
11.55 -
11.56 -local
11.57 -fun collect applevel (Var _) arity = arity
11.58 - | collect applevel (Const c) arity = update_arity arity c applevel
11.59 - | collect applevel (Abs m) arity = collect 0 m arity
11.60 - | collect applevel (App (a,b)) arity = collect 0 b (collect (applevel + 1) a arity)
11.61 -in
11.62 -fun collect_term_arity t arity = collect 0 t arity
11.63 -end
11.64 -
11.65 -fun collect_guard_arity (Guard (a,b)) arity = collect_term_arity b (collect_term_arity a arity)
11.66 -
11.67 -
11.68 -fun rep n x = if n < 0 then raise Compile "internal error: rep" else if n = 0 then [] else x::(rep (n-1) x)
11.69 -
11.70 -fun beta (Const c) = Const c
11.71 - | beta (Var i) = Var i
11.72 - | beta (App (Abs m, b)) = beta (unlift 0 (subst 0 m (lift 0 b)))
11.73 - | beta (App (a, b)) =
11.74 - (case beta a of
11.75 - Abs m => beta (App (Abs m, b))
11.76 - | a => App (a, beta b))
11.77 - | beta (Abs m) = Abs (beta m)
11.78 - | beta (Computed t) = Computed t
11.79 -and subst x (Const c) t = Const c
11.80 - | subst x (Var i) t = if i = x then t else Var i
11.81 - | subst x (App (a,b)) t = App (subst x a t, subst x b t)
11.82 - | subst x (Abs m) t = Abs (subst (x+1) m (lift 0 t))
11.83 -and lift level (Const c) = Const c
11.84 - | lift level (App (a,b)) = App (lift level a, lift level b)
11.85 - | lift level (Var i) = if i < level then Var i else Var (i+1)
11.86 - | lift level (Abs m) = Abs (lift (level + 1) m)
11.87 -and unlift level (Const c) = Const c
11.88 - | unlift level (App (a, b)) = App (unlift level a, unlift level b)
11.89 - | unlift level (Abs m) = Abs (unlift (level+1) m)
11.90 - | unlift level (Var i) = if i < level then Var i else Var (i-1)
11.91 -
11.92 -fun nlift level n (Var m) = if m < level then Var m else Var (m+n)
11.93 - | nlift level n (Const c) = Const c
11.94 - | nlift level n (App (a,b)) = App (nlift level n a, nlift level n b)
11.95 - | nlift level n (Abs b) = Abs (nlift (level+1) n b)
11.96 -
11.97 -fun subst_const (c, t) (Const c') = if c = c' then t else Const c'
11.98 - | subst_const _ (Var i) = Var i
11.99 - | subst_const ct (App (a, b)) = App (subst_const ct a, subst_const ct b)
11.100 - | subst_const ct (Abs m) = Abs (subst_const ct m)
11.101 -
11.102 -(* Remove all rules that are just parameterless rewrites. This is necessary because SML does not allow functions with no parameters. *)
11.103 -fun inline_rules rules =
11.104 - let
11.105 - fun term_contains_const c (App (a, b)) = term_contains_const c a orelse term_contains_const c b
11.106 - | term_contains_const c (Abs m) = term_contains_const c m
11.107 - | term_contains_const c (Var _) = false
11.108 - | term_contains_const c (Const c') = (c = c')
11.109 - fun find_rewrite [] = NONE
11.110 - | find_rewrite ((prems, PConst (c, []), r) :: _) =
11.111 - if check_freevars 0 r then
11.112 - if term_contains_const c r then
11.113 - raise Compile "parameterless rewrite is caught in cycle"
11.114 - else if not (null prems) then
11.115 - raise Compile "parameterless rewrite may not be guarded"
11.116 - else
11.117 - SOME (c, r)
11.118 - else raise Compile "unbound variable on right hand side or guards of rule"
11.119 - | find_rewrite (_ :: rules) = find_rewrite rules
11.120 - fun remove_rewrite _ [] = []
11.121 - | remove_rewrite (cr as (c, r)) ((rule as (prems', PConst (c', args), r')) :: rules) =
11.122 - if c = c' then
11.123 - if null args andalso r = r' andalso null prems' then remove_rewrite cr rules
11.124 - else raise Compile "incompatible parameterless rewrites found"
11.125 - else
11.126 - rule :: remove_rewrite cr rules
11.127 - | remove_rewrite cr (r :: rs) = r :: remove_rewrite cr rs
11.128 - fun pattern_contains_const c (PConst (c', args)) = c = c' orelse exists (pattern_contains_const c) args
11.129 - | pattern_contains_const c (PVar) = false
11.130 - fun inline_rewrite (ct as (c, _)) (prems, p, r) =
11.131 - if pattern_contains_const c p then
11.132 - raise Compile "parameterless rewrite cannot be used in pattern"
11.133 - else (map (fn (Guard (a, b)) => Guard (subst_const ct a, subst_const ct b)) prems, p, subst_const ct r)
11.134 - fun inline inlined rules =
11.135 - case find_rewrite rules of
11.136 - NONE => (Inttab.make inlined, rules)
11.137 - | SOME ct =>
11.138 - let
11.139 - val rules = map (inline_rewrite ct) (remove_rewrite ct rules)
11.140 - val inlined = ct :: (map o apsnd) (subst_const ct) inlined
11.141 - in inline inlined rules end
11.142 - in
11.143 - inline [] rules
11.144 - end
11.145 -
11.146 -
11.147 -(*
11.148 - Calculate the arity, the toplevel_arity, and adjust rules so that all toplevel pattern constants have maximal arity.
11.149 - Also beta reduce the adjusted right hand side of a rule.
11.150 -*)
11.151 -fun adjust_rules rules =
11.152 - let
11.153 - val arity = fold (fn (prems, p, t) => fn arity => fold collect_guard_arity prems (collect_term_arity t (collect_pattern_arity p arity))) rules Inttab.empty
11.154 - val toplevel_arity = fold (fn (_, p, _) => fn arity => collect_pattern_toplevel_arity p arity) rules Inttab.empty
11.155 - fun arity_of c = the (Inttab.lookup arity c)
11.156 - fun test_pattern PVar = ()
11.157 - | test_pattern (PConst (c, args)) = if (length args <> arity_of c) then raise Compile ("Constant inside pattern must have maximal arity") else (map test_pattern args; ())
11.158 - fun adjust_rule (_, PVar, _) = raise Compile ("pattern may not be a variable")
11.159 - | adjust_rule (_, PConst (_, []), _) = raise Compile ("cannot deal with rewrites that take no parameters")
11.160 - | adjust_rule (rule as (prems, p as PConst (c, args),t)) =
11.161 - let
11.162 - val patternvars_counted = count_patternvars p
11.163 - fun check_fv t = check_freevars patternvars_counted t
11.164 - val _ = if not (check_fv t) then raise Compile ("unbound variables on right hand side of rule") else ()
11.165 - val _ = if not (forall (fn (Guard (a,b)) => check_fv a andalso check_fv b) prems) then raise Compile ("unbound variables in guards") else ()
11.166 - val _ = map test_pattern args
11.167 - val len = length args
11.168 - val arity = arity_of c
11.169 - val lift = nlift 0
11.170 - fun addapps_tm n t = if n=0 then t else addapps_tm (n-1) (App (t, Var (n-1)))
11.171 - fun adjust_term n t = addapps_tm n (lift n t)
11.172 - fun adjust_guard n (Guard (a,b)) = Guard (lift n a, lift n b)
11.173 - in
11.174 - if len = arity then
11.175 - rule
11.176 - else if arity >= len then
11.177 - (map (adjust_guard (arity-len)) prems, PConst (c, args @ (rep (arity-len) PVar)), adjust_term (arity-len) t)
11.178 - else (raise Compile "internal error in adjust_rule")
11.179 - end
11.180 - fun beta_rule (prems, p, t) = ((prems, p, beta t) handle Match => raise Compile "beta_rule")
11.181 - in
11.182 - (arity, toplevel_arity, map (beta_rule o adjust_rule) rules)
11.183 - end
11.184 -
11.185 -fun print_term module arity_of toplevel_arity_of pattern_var_count pattern_lazy_var_count =
11.186 -let
11.187 - fun str x = string_of_int x
11.188 - fun protect_blank s = if exists_string Symbol.is_ascii_blank s then "(" ^ s ^")" else s
11.189 - val module_prefix = (case module of NONE => "" | SOME s => s^".")
11.190 - fun print_apps d f [] = f
11.191 - | print_apps d f (a::args) = print_apps d (module_prefix^"app "^(protect_blank f)^" "^(protect_blank (print_term d a))) args
11.192 - and print_call d (App (a, b)) args = print_call d a (b::args)
11.193 - | print_call d (Const c) args =
11.194 - (case arity_of c of
11.195 - NONE => print_apps d (module_prefix^"Const "^(str c)) args
11.196 - | SOME 0 => module_prefix^"C"^(str c)
11.197 - | SOME a =>
11.198 - let
11.199 - val len = length args
11.200 - in
11.201 - if a <= len then
11.202 - let
11.203 - val strict_a = (case toplevel_arity_of c of SOME sa => sa | NONE => a)
11.204 - val _ = if strict_a > a then raise Compile "strict" else ()
11.205 - val s = module_prefix^"c"^(str c)^(implode (map (fn t => " "^(protect_blank (print_term d t))) (List.take (args, strict_a))))
11.206 - val s = s^(implode (map (fn t => " (fn () => "^print_term d t^")") (List.drop (List.take (args, a), strict_a))))
11.207 - in
11.208 - print_apps d s (List.drop (args, a))
11.209 - end
11.210 - else
11.211 - let
11.212 - fun mk_apps n t = if n = 0 then t else mk_apps (n-1) (App (t, Var (n - 1)))
11.213 - fun mk_lambdas n t = if n = 0 then t else mk_lambdas (n-1) (Abs t)
11.214 - fun append_args [] t = t
11.215 - | append_args (c::cs) t = append_args cs (App (t, c))
11.216 - in
11.217 - print_term d (mk_lambdas (a-len) (mk_apps (a-len) (nlift 0 (a-len) (append_args args (Const c)))))
11.218 - end
11.219 - end)
11.220 - | print_call d t args = print_apps d (print_term d t) args
11.221 - and print_term d (Var x) =
11.222 - if x < d then
11.223 - "b"^(str (d-x-1))
11.224 - else
11.225 - let
11.226 - val n = pattern_var_count - (x-d) - 1
11.227 - val x = "x"^(str n)
11.228 - in
11.229 - if n < pattern_var_count - pattern_lazy_var_count then
11.230 - x
11.231 - else
11.232 - "("^x^" ())"
11.233 - end
11.234 - | print_term d (Abs c) = module_prefix^"Abs (fn b"^(str d)^" => "^(print_term (d + 1) c)^")"
11.235 - | print_term d t = print_call d t []
11.236 -in
11.237 - print_term 0
11.238 -end
11.239 -
11.240 -fun section n = if n = 0 then [] else (section (n-1))@[n-1]
11.241 -
11.242 -fun print_rule gnum arity_of toplevel_arity_of (guards, p, t) =
11.243 - let
11.244 - fun str x = string_of_int x
11.245 - fun print_pattern top n PVar = (n+1, "x"^(str n))
11.246 - | print_pattern top n (PConst (c, [])) = (n, (if top then "c" else "C")^(str c)^(if top andalso gnum > 0 then "_"^(str gnum) else ""))
11.247 - | print_pattern top n (PConst (c, args)) =
11.248 - let
11.249 - val f = (if top then "c" else "C")^(str c)^(if top andalso gnum > 0 then "_"^(str gnum) else "")
11.250 - val (n, s) = print_pattern_list 0 top (n, f) args
11.251 - in
11.252 - (n, s)
11.253 - end
11.254 - and print_pattern_list' counter top (n,p) [] = if top then (n,p) else (n,p^")")
11.255 - | print_pattern_list' counter top (n, p) (t::ts) =
11.256 - let
11.257 - val (n, t) = print_pattern false n t
11.258 - in
11.259 - print_pattern_list' (counter + 1) top (n, if top then p^" (a"^(str counter)^" as ("^t^"))" else p^", "^t) ts
11.260 - end
11.261 - and print_pattern_list counter top (n, p) (t::ts) =
11.262 - let
11.263 - val (n, t) = print_pattern false n t
11.264 - in
11.265 - print_pattern_list' (counter + 1) top (n, if top then p^" (a"^(str counter)^" as ("^t^"))" else p^" ("^t) ts
11.266 - end
11.267 - val c = (case p of PConst (c, _) => c | _ => raise Match)
11.268 - val (n, pattern) = print_pattern true 0 p
11.269 - val lazy_vars = the (arity_of c) - the (toplevel_arity_of c)
11.270 - fun print_tm tm = print_term NONE arity_of toplevel_arity_of n lazy_vars tm
11.271 - fun print_guard (Guard (a,b)) = "term_eq ("^(print_tm a)^") ("^(print_tm b)^")"
11.272 - val else_branch = "c"^(str c)^"_"^(str (gnum+1))^(implode (map (fn i => " a"^(str i)) (section (the (arity_of c)))))
11.273 - fun print_guards t [] = print_tm t
11.274 - | print_guards t (g::gs) = "if ("^(print_guard g)^")"^(implode (map (fn g => " andalso ("^(print_guard g)^")") gs))^" then ("^(print_tm t)^") else "^else_branch
11.275 - in
11.276 - (if null guards then gnum else gnum+1, pattern^" = "^(print_guards t guards))
11.277 - end
11.278 -
11.279 -fun group_rules rules =
11.280 - let
11.281 - fun add_rule (r as (_, PConst (c,_), _)) groups =
11.282 - let
11.283 - val rs = (case Inttab.lookup groups c of NONE => [] | SOME rs => rs)
11.284 - in
11.285 - Inttab.update (c, r::rs) groups
11.286 - end
11.287 - | add_rule _ _ = raise Compile "internal error group_rules"
11.288 - in
11.289 - fold_rev add_rule rules Inttab.empty
11.290 - end
11.291 -
11.292 -fun sml_prog name code rules =
11.293 - let
11.294 - val buffer = Unsynchronized.ref ""
11.295 - fun write s = (buffer := (!buffer)^s)
11.296 - fun writeln s = (write s; write "\n")
11.297 - fun writelist [] = ()
11.298 - | writelist (s::ss) = (writeln s; writelist ss)
11.299 - fun str i = string_of_int i
11.300 - val (inlinetab, rules) = inline_rules rules
11.301 - val (arity, toplevel_arity, rules) = adjust_rules rules
11.302 - val rules = group_rules rules
11.303 - val constants = Inttab.keys arity
11.304 - fun arity_of c = Inttab.lookup arity c
11.305 - fun toplevel_arity_of c = Inttab.lookup toplevel_arity c
11.306 - fun rep_str s n = implode (rep n s)
11.307 - fun indexed s n = s^(str n)
11.308 - fun string_of_tuple [] = ""
11.309 - | string_of_tuple (x::xs) = "("^x^(implode (map (fn s => ", "^s) xs))^")"
11.310 - fun string_of_args [] = ""
11.311 - | string_of_args (x::xs) = x^(implode (map (fn s => " "^s) xs))
11.312 - fun default_case gnum c =
11.313 - let
11.314 - val leftargs = implode (map (indexed " x") (section (the (arity_of c))))
11.315 - val rightargs = section (the (arity_of c))
11.316 - val strict_args = (case toplevel_arity_of c of NONE => the (arity_of c) | SOME sa => sa)
11.317 - val xs = map (fn n => if n < strict_args then "x"^(str n) else "x"^(str n)^"()") rightargs
11.318 - val right = (indexed "C" c)^" "^(string_of_tuple xs)
11.319 - val message = "(\"unresolved lazy call: " ^ string_of_int c ^ "\")"
11.320 - val right = if strict_args < the (arity_of c) then "raise AM_SML.Run "^message else right
11.321 - in
11.322 - (indexed "c" c)^(if gnum > 0 then "_"^(str gnum) else "")^leftargs^" = "^right
11.323 - end
11.324 -
11.325 - fun eval_rules c =
11.326 - let
11.327 - val arity = the (arity_of c)
11.328 - val strict_arity = (case toplevel_arity_of c of NONE => arity | SOME sa => sa)
11.329 - fun eval_rule n =
11.330 - let
11.331 - val sc = string_of_int c
11.332 - val left = fold (fn i => fn s => "AbstractMachine.App ("^s^(indexed ", x" i)^")") (section n) ("AbstractMachine.Const "^sc)
11.333 - fun arg i =
11.334 - let
11.335 - val x = indexed "x" i
11.336 - val x = if i < n then "(eval bounds "^x^")" else x
11.337 - val x = if i < strict_arity then x else "(fn () => "^x^")"
11.338 - in
11.339 - x
11.340 - end
11.341 - val right = "c"^sc^" "^(string_of_args (map arg (section arity)))
11.342 - val right = fold_rev (fn i => fn s => "Abs (fn "^(indexed "x" i)^" => "^s^")") (List.drop (section arity, n)) right
11.343 - val right = if arity > 0 then right else "C"^sc
11.344 - in
11.345 - " | eval bounds ("^left^") = "^right
11.346 - end
11.347 - in
11.348 - map eval_rule (rev (section (arity + 1)))
11.349 - end
11.350 -
11.351 - fun convert_computed_rules (c: int) : string list =
11.352 - let
11.353 - val arity = the (arity_of c)
11.354 - fun eval_rule () =
11.355 - let
11.356 - val sc = string_of_int c
11.357 - val left = fold (fn i => fn s => "AbstractMachine.App ("^s^(indexed ", x" i)^")") (section arity) ("AbstractMachine.Const "^sc)
11.358 - fun arg i = "(convert_computed "^(indexed "x" i)^")"
11.359 - val right = "C"^sc^" "^(string_of_tuple (map arg (section arity)))
11.360 - val right = if arity > 0 then right else "C"^sc
11.361 - in
11.362 - " | convert_computed ("^left^") = "^right
11.363 - end
11.364 - in
11.365 - [eval_rule ()]
11.366 - end
11.367 -
11.368 - fun mk_constr_type_args n = if n > 0 then " of Term "^(rep_str " * Term" (n-1)) else ""
11.369 - val _ = writelist [
11.370 - "structure "^name^" = struct",
11.371 - "",
11.372 - "datatype Term = Const of int | App of Term * Term | Abs of (Term -> Term)",
11.373 - " "^(implode (map (fn c => " | C"^(str c)^(mk_constr_type_args (the (arity_of c)))) constants)),
11.374 - ""]
11.375 - fun make_constr c argprefix = "(C"^(str c)^" "^(string_of_tuple (map (fn i => argprefix^(str i)) (section (the (arity_of c)))))^")"
11.376 - fun make_term_eq c = " | term_eq "^(make_constr c "a")^" "^(make_constr c "b")^" = "^
11.377 - (case the (arity_of c) of
11.378 - 0 => "true"
11.379 - | n =>
11.380 - let
11.381 - val eqs = map (fn i => "term_eq a"^(str i)^" b"^(str i)) (section n)
11.382 - val (eq, eqs) = (List.hd eqs, map (fn s => " andalso "^s) (List.tl eqs))
11.383 - in
11.384 - eq^(implode eqs)
11.385 - end)
11.386 - val _ = writelist [
11.387 - "fun term_eq (Const c1) (Const c2) = (c1 = c2)",
11.388 - " | term_eq (App (a1,a2)) (App (b1,b2)) = term_eq a1 b1 andalso term_eq a2 b2"]
11.389 - val _ = writelist (map make_term_eq constants)
11.390 - val _ = writelist [
11.391 - " | term_eq _ _ = false",
11.392 - ""
11.393 - ]
11.394 - val _ = writelist [
11.395 - "fun app (Abs a) b = a b",
11.396 - " | app a b = App (a, b)",
11.397 - ""]
11.398 - fun defcase gnum c = (case arity_of c of NONE => [] | SOME a => if a > 0 then [default_case gnum c] else [])
11.399 - fun writefundecl [] = ()
11.400 - | writefundecl (x::xs) = writelist ((("and "^x)::(map (fn s => " | "^s) xs)))
11.401 - fun list_group c = (case Inttab.lookup rules c of
11.402 - NONE => [defcase 0 c]
11.403 - | SOME rs =>
11.404 - let
11.405 - val rs =
11.406 - fold
11.407 - (fn r =>
11.408 - fn rs =>
11.409 - let
11.410 - val (gnum, l, rs) =
11.411 - (case rs of
11.412 - [] => (0, [], [])
11.413 - | (gnum, l)::rs => (gnum, l, rs))
11.414 - val (gnum', r) = print_rule gnum arity_of toplevel_arity_of r
11.415 - in
11.416 - if gnum' = gnum then
11.417 - (gnum, r::l)::rs
11.418 - else
11.419 - let
11.420 - val args = implode (map (fn i => " a"^(str i)) (section (the (arity_of c))))
11.421 - fun gnumc g = if g > 0 then "c"^(str c)^"_"^(str g)^args else "c"^(str c)^args
11.422 - val s = gnumc (gnum) ^ " = " ^ gnumc (gnum')
11.423 - in
11.424 - (gnum', [])::(gnum, s::r::l)::rs
11.425 - end
11.426 - end)
11.427 - rs []
11.428 - val rs = (case rs of [] => [(0,defcase 0 c)] | (gnum,l)::rs => (gnum, (defcase gnum c)@l)::rs)
11.429 - in
11.430 - rev (map (fn z => rev (snd z)) rs)
11.431 - end)
11.432 - val _ = map (fn z => (map writefundecl z; writeln "")) (map list_group constants)
11.433 - val _ = writelist [
11.434 - "fun convert (Const i) = AM_SML.Const i",
11.435 - " | convert (App (a, b)) = AM_SML.App (convert a, convert b)",
11.436 - " | convert (Abs _) = raise AM_SML.Run \"no abstraction in result allowed\""]
11.437 - fun make_convert c =
11.438 - let
11.439 - val args = map (indexed "a") (section (the (arity_of c)))
11.440 - val leftargs =
11.441 - case args of
11.442 - [] => ""
11.443 - | (x::xs) => "("^x^(implode (map (fn s => ", "^s) xs))^")"
11.444 - val args = map (indexed "convert a") (section (the (arity_of c)))
11.445 - val right = fold (fn x => fn s => "AM_SML.App ("^s^", "^x^")") args ("AM_SML.Const "^(str c))
11.446 - in
11.447 - " | convert (C"^(str c)^" "^leftargs^") = "^right
11.448 - end
11.449 - val _ = writelist (map make_convert constants)
11.450 - val _ = writelist [
11.451 - "",
11.452 - "fun convert_computed (AbstractMachine.Abs b) = raise AM_SML.Run \"no abstraction in convert_computed allowed\"",
11.453 - " | convert_computed (AbstractMachine.Var i) = raise AM_SML.Run \"no bound variables in convert_computed allowed\""]
11.454 - val _ = map (writelist o convert_computed_rules) constants
11.455 - val _ = writelist [
11.456 - " | convert_computed (AbstractMachine.Const c) = Const c",
11.457 - " | convert_computed (AbstractMachine.App (a, b)) = App (convert_computed a, convert_computed b)",
11.458 - " | convert_computed (AbstractMachine.Computed a) = raise AM_SML.Run \"no nesting in convert_computed allowed\""]
11.459 - val _ = writelist [
11.460 - "",
11.461 - "fun eval bounds (AbstractMachine.Abs m) = Abs (fn b => eval (b::bounds) m)",
11.462 - " | eval bounds (AbstractMachine.Var i) = AM_SML.list_nth (bounds, i)"]
11.463 - val _ = map (writelist o eval_rules) constants
11.464 - val _ = writelist [
11.465 - " | eval bounds (AbstractMachine.App (a, b)) = app (eval bounds a) (eval bounds b)",
11.466 - " | eval bounds (AbstractMachine.Const c) = Const c",
11.467 - " | eval bounds (AbstractMachine.Computed t) = convert_computed t"]
11.468 - val _ = writelist [
11.469 - "",
11.470 - "fun export term = AM_SML.save_result (\""^code^"\", convert term)",
11.471 - "",
11.472 - "val _ = AM_SML.set_compiled_rewriter (fn t => (convert (eval [] t)))",
11.473 - "",
11.474 - "end"]
11.475 - in
11.476 - (inlinetab, !buffer)
11.477 - end
11.478 -
11.479 -val guid_counter = Unsynchronized.ref 0
11.480 -fun get_guid () =
11.481 - let
11.482 - val c = !guid_counter
11.483 - val _ = guid_counter := !guid_counter + 1
11.484 - in
11.485 - string_of_int (Time.toMicroseconds (Time.now ())) ^ string_of_int c
11.486 - end
11.487 -
11.488 -
11.489 -fun writeTextFile name s = File.write (Path.explode name) s
11.490 -
11.491 -fun use_source src = use_text ML_Env.local_context (1, "") false src
11.492 -
11.493 -fun compile rules =
11.494 - let
11.495 - val guid = get_guid ()
11.496 - val code = Real.toString (random ())
11.497 - val name = "AMSML_"^guid
11.498 - val (inlinetab, source) = sml_prog name code rules
11.499 - val _ = case !dump_output of NONE => () | SOME p => writeTextFile p source
11.500 - val _ = compiled_rewriter := NONE
11.501 - val _ = use_source source
11.502 - in
11.503 - case !compiled_rewriter of
11.504 - NONE => raise Compile "broken link to compiled function"
11.505 - | SOME compiled_fun => (inlinetab, compiled_fun)
11.506 - end
11.507 -
11.508 -fun run (inlinetab, compiled_fun) t =
11.509 - let
11.510 - val _ = if check_freevars 0 t then () else raise Run ("can only compute closed terms")
11.511 - fun inline (Const c) = (case Inttab.lookup inlinetab c of NONE => Const c | SOME t => t)
11.512 - | inline (Var i) = Var i
11.513 - | inline (App (a, b)) = App (inline a, inline b)
11.514 - | inline (Abs m) = Abs (inline m)
11.515 - | inline (Computed t) = Computed t
11.516 - in
11.517 - compiled_fun (beta (inline t))
11.518 - end
11.519 -
11.520 -end
12.1 --- a/src/HOL/Matrix/Compute_Oracle/compute.ML Sat Mar 17 12:26:19 2012 +0100
12.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
12.3 @@ -1,653 +0,0 @@
12.4 -(* Title: HOL/Matrix/Compute_Oracle/compute.ML
12.5 - Author: Steven Obua
12.6 -*)
12.7 -
12.8 -signature COMPUTE = sig
12.9 -
12.10 - type computer
12.11 - type theorem
12.12 - type naming = int -> string
12.13 -
12.14 - datatype machine = BARRAS | BARRAS_COMPILED | HASKELL | SML
12.15 -
12.16 - (* Functions designated with a ! in front of them actually update the computer parameter *)
12.17 -
12.18 - exception Make of string
12.19 - val make : machine -> theory -> thm list -> computer
12.20 - val make_with_cache : machine -> theory -> term list -> thm list -> computer
12.21 - val theory_of : computer -> theory
12.22 - val hyps_of : computer -> term list
12.23 - val shyps_of : computer -> sort list
12.24 - (* ! *) val update : computer -> thm list -> unit
12.25 - (* ! *) val update_with_cache : computer -> term list -> thm list -> unit
12.26 -
12.27 - (* ! *) val set_naming : computer -> naming -> unit
12.28 - val naming_of : computer -> naming
12.29 -
12.30 - exception Compute of string
12.31 - val simplify : computer -> theorem -> thm
12.32 - val rewrite : computer -> cterm -> thm
12.33 -
12.34 - val make_theorem : computer -> thm -> string list -> theorem
12.35 - (* ! *) val instantiate : computer -> (string * cterm) list -> theorem -> theorem
12.36 - (* ! *) val evaluate_prem : computer -> int -> theorem -> theorem
12.37 - (* ! *) val modus_ponens : computer -> int -> thm -> theorem -> theorem
12.38 -
12.39 -end
12.40 -
12.41 -structure Compute :> COMPUTE = struct
12.42 -
12.43 -open Report;
12.44 -
12.45 -datatype machine = BARRAS | BARRAS_COMPILED | HASKELL | SML
12.46 -
12.47 -(* Terms are mapped to integer codes *)
12.48 -structure Encode :>
12.49 -sig
12.50 - type encoding
12.51 - val empty : encoding
12.52 - val insert : term -> encoding -> int * encoding
12.53 - val lookup_code : term -> encoding -> int option
12.54 - val lookup_term : int -> encoding -> term option
12.55 - val remove_code : int -> encoding -> encoding
12.56 - val remove_term : term -> encoding -> encoding
12.57 -end
12.58 -=
12.59 -struct
12.60 -
12.61 -type encoding = int * (int Termtab.table) * (term Inttab.table)
12.62 -
12.63 -val empty = (0, Termtab.empty, Inttab.empty)
12.64 -
12.65 -fun insert t (e as (count, term2int, int2term)) =
12.66 - (case Termtab.lookup term2int t of
12.67 - NONE => (count, (count+1, Termtab.update_new (t, count) term2int, Inttab.update_new (count, t) int2term))
12.68 - | SOME code => (code, e))
12.69 -
12.70 -fun lookup_code t (_, term2int, _) = Termtab.lookup term2int t
12.71 -
12.72 -fun lookup_term c (_, _, int2term) = Inttab.lookup int2term c
12.73 -
12.74 -fun remove_code c (e as (count, term2int, int2term)) =
12.75 - (case lookup_term c e of NONE => e | SOME t => (count, Termtab.delete t term2int, Inttab.delete c int2term))
12.76 -
12.77 -fun remove_term t (e as (count, term2int, int2term)) =
12.78 - (case lookup_code t e of NONE => e | SOME c => (count, Termtab.delete t term2int, Inttab.delete c int2term))
12.79 -
12.80 -end
12.81 -
12.82 -exception Make of string;
12.83 -exception Compute of string;
12.84 -
12.85 -local
12.86 - fun make_constant t encoding =
12.87 - let
12.88 - val (code, encoding) = Encode.insert t encoding
12.89 - in
12.90 - (encoding, AbstractMachine.Const code)
12.91 - end
12.92 -in
12.93 -
12.94 -fun remove_types encoding t =
12.95 - case t of
12.96 - Var _ => make_constant t encoding
12.97 - | Free _ => make_constant t encoding
12.98 - | Const _ => make_constant t encoding
12.99 - | Abs (_, _, t') =>
12.100 - let val (encoding, t'') = remove_types encoding t' in
12.101 - (encoding, AbstractMachine.Abs t'')
12.102 - end
12.103 - | a $ b =>
12.104 - let
12.105 - val (encoding, a) = remove_types encoding a
12.106 - val (encoding, b) = remove_types encoding b
12.107 - in
12.108 - (encoding, AbstractMachine.App (a,b))
12.109 - end
12.110 - | Bound b => (encoding, AbstractMachine.Var b)
12.111 -end
12.112 -
12.113 -local
12.114 - fun type_of (Free (_, ty)) = ty
12.115 - | type_of (Const (_, ty)) = ty
12.116 - | type_of (Var (_, ty)) = ty
12.117 - | type_of _ = raise Fail "infer_types: type_of error"
12.118 -in
12.119 -fun infer_types naming encoding =
12.120 - let
12.121 - fun infer_types _ bounds _ (AbstractMachine.Var v) = (Bound v, nth bounds v)
12.122 - | infer_types _ bounds _ (AbstractMachine.Const code) =
12.123 - let
12.124 - val c = the (Encode.lookup_term code encoding)
12.125 - in
12.126 - (c, type_of c)
12.127 - end
12.128 - | infer_types level bounds _ (AbstractMachine.App (a, b)) =
12.129 - let
12.130 - val (a, aty) = infer_types level bounds NONE a
12.131 - val (adom, arange) =
12.132 - case aty of
12.133 - Type ("fun", [dom, range]) => (dom, range)
12.134 - | _ => raise Fail "infer_types: function type expected"
12.135 - val (b, _) = infer_types level bounds (SOME adom) b
12.136 - in
12.137 - (a $ b, arange)
12.138 - end
12.139 - | infer_types level bounds (SOME (ty as Type ("fun", [dom, range]))) (AbstractMachine.Abs m) =
12.140 - let
12.141 - val (m, _) = infer_types (level+1) (dom::bounds) (SOME range) m
12.142 - in
12.143 - (Abs (naming level, dom, m), ty)
12.144 - end
12.145 - | infer_types _ _ NONE (AbstractMachine.Abs _) =
12.146 - raise Fail "infer_types: cannot infer type of abstraction"
12.147 -
12.148 - fun infer ty term =
12.149 - let
12.150 - val (term', _) = infer_types 0 [] (SOME ty) term
12.151 - in
12.152 - term'
12.153 - end
12.154 - in
12.155 - infer
12.156 - end
12.157 -end
12.158 -
12.159 -datatype prog =
12.160 - ProgBarras of AM_Interpreter.program
12.161 - | ProgBarrasC of AM_Compiler.program
12.162 - | ProgHaskell of AM_GHC.program
12.163 - | ProgSML of AM_SML.program
12.164 -
12.165 -fun machine_of_prog (ProgBarras _) = BARRAS
12.166 - | machine_of_prog (ProgBarrasC _) = BARRAS_COMPILED
12.167 - | machine_of_prog (ProgHaskell _) = HASKELL
12.168 - | machine_of_prog (ProgSML _) = SML
12.169 -
12.170 -type naming = int -> string
12.171 -
12.172 -fun default_naming i = "v_" ^ string_of_int i
12.173 -
12.174 -datatype computer = Computer of
12.175 - (theory_ref * Encode.encoding * term list * unit Sorttab.table * prog * unit Unsynchronized.ref * naming)
12.176 - option Unsynchronized.ref
12.177 -
12.178 -fun theory_of (Computer (Unsynchronized.ref (SOME (rthy,_,_,_,_,_,_)))) = Theory.deref rthy
12.179 -fun hyps_of (Computer (Unsynchronized.ref (SOME (_,_,hyps,_,_,_,_)))) = hyps
12.180 -fun shyps_of (Computer (Unsynchronized.ref (SOME (_,_,_,shyptable,_,_,_)))) = Sorttab.keys (shyptable)
12.181 -fun shyptab_of (Computer (Unsynchronized.ref (SOME (_,_,_,shyptable,_,_,_)))) = shyptable
12.182 -fun stamp_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,_,stamp,_)))) = stamp
12.183 -fun prog_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,prog,_,_)))) = prog
12.184 -fun encoding_of (Computer (Unsynchronized.ref (SOME (_,encoding,_,_,_,_,_)))) = encoding
12.185 -fun set_encoding (Computer (r as Unsynchronized.ref (SOME (p1,_,p2,p3,p4,p5,p6)))) encoding' =
12.186 - (r := SOME (p1,encoding',p2,p3,p4,p5,p6))
12.187 -fun naming_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,_,_,n)))) = n
12.188 -fun set_naming (Computer (r as Unsynchronized.ref (SOME (p1,p2,p3,p4,p5,p6,_)))) naming'=
12.189 - (r := SOME (p1,p2,p3,p4,p5,p6,naming'))
12.190 -
12.191 -fun ref_of (Computer r) = r
12.192 -
12.193 -datatype cthm = ComputeThm of term list * sort list * term
12.194 -
12.195 -fun thm2cthm th =
12.196 - let
12.197 - val {hyps, prop, tpairs, shyps, ...} = Thm.rep_thm th
12.198 - val _ = if not (null tpairs) then raise Make "theorems may not contain tpairs" else ()
12.199 - in
12.200 - ComputeThm (hyps, shyps, prop)
12.201 - end
12.202 -
12.203 -fun make_internal machine thy stamp encoding cache_pattern_terms raw_ths =
12.204 - let
12.205 - fun transfer (x:thm) = Thm.transfer thy x
12.206 - val ths = map (thm2cthm o Thm.strip_shyps o transfer) raw_ths
12.207 -
12.208 - fun make_pattern encoding n vars (AbstractMachine.Abs _) =
12.209 - raise (Make "no lambda abstractions allowed in pattern")
12.210 - | make_pattern encoding n vars (AbstractMachine.Var _) =
12.211 - raise (Make "no bound variables allowed in pattern")
12.212 - | make_pattern encoding n vars (AbstractMachine.Const code) =
12.213 - (case the (Encode.lookup_term code encoding) of
12.214 - Var _ => ((n+1, Inttab.update_new (code, n) vars, AbstractMachine.PVar)
12.215 - handle Inttab.DUP _ => raise (Make "no duplicate variable in pattern allowed"))
12.216 - | _ => (n, vars, AbstractMachine.PConst (code, [])))
12.217 - | make_pattern encoding n vars (AbstractMachine.App (a, b)) =
12.218 - let
12.219 - val (n, vars, pa) = make_pattern encoding n vars a
12.220 - val (n, vars, pb) = make_pattern encoding n vars b
12.221 - in
12.222 - case pa of
12.223 - AbstractMachine.PVar =>
12.224 - raise (Make "patterns may not start with a variable")
12.225 - | AbstractMachine.PConst (c, args) =>
12.226 - (n, vars, AbstractMachine.PConst (c, args@[pb]))
12.227 - end
12.228 -
12.229 - fun thm2rule (encoding, hyptable, shyptable) th =
12.230 - let
12.231 - val (ComputeThm (hyps, shyps, prop)) = th
12.232 - val hyptable = fold (fn h => Termtab.update (h, ())) hyps hyptable
12.233 - val shyptable = fold (fn sh => Sorttab.update (sh, ())) shyps shyptable
12.234 - val (prems, prop) = (Logic.strip_imp_prems prop, Logic.strip_imp_concl prop)
12.235 - val (a, b) = Logic.dest_equals prop
12.236 - handle TERM _ => raise (Make "theorems must be meta-level equations (with optional guards)")
12.237 - val a = Envir.eta_contract a
12.238 - val b = Envir.eta_contract b
12.239 - val prems = map Envir.eta_contract prems
12.240 -
12.241 - val (encoding, left) = remove_types encoding a
12.242 - val (encoding, right) = remove_types encoding b
12.243 - fun remove_types_of_guard encoding g =
12.244 - (let
12.245 - val (t1, t2) = Logic.dest_equals g
12.246 - val (encoding, t1) = remove_types encoding t1
12.247 - val (encoding, t2) = remove_types encoding t2
12.248 - in
12.249 - (encoding, AbstractMachine.Guard (t1, t2))
12.250 - end handle TERM _ => raise (Make "guards must be meta-level equations"))
12.251 - val (encoding, prems) = fold_rev (fn p => fn (encoding, ps) => let val (e, p) = remove_types_of_guard encoding p in (e, p::ps) end) prems (encoding, [])
12.252 -
12.253 - (* Principally, a check should be made here to see if the (meta-) hyps contain any of the variables of the rule.
12.254 - As it is, all variables of the rule are schematic, and there are no schematic variables in meta-hyps, therefore
12.255 - this check can be left out. *)
12.256 -
12.257 - val (vcount, vars, pattern) = make_pattern encoding 0 Inttab.empty left
12.258 - val _ = (case pattern of
12.259 - AbstractMachine.PVar =>
12.260 - raise (Make "patterns may not start with a variable")
12.261 - | _ => ())
12.262 -
12.263 - (* finally, provide a function for renaming the
12.264 - pattern bound variables on the right hand side *)
12.265 -
12.266 - fun rename level vars (var as AbstractMachine.Var _) = var
12.267 - | rename level vars (c as AbstractMachine.Const code) =
12.268 - (case Inttab.lookup vars code of
12.269 - NONE => c
12.270 - | SOME n => AbstractMachine.Var (vcount-n-1+level))
12.271 - | rename level vars (AbstractMachine.App (a, b)) =
12.272 - AbstractMachine.App (rename level vars a, rename level vars b)
12.273 - | rename level vars (AbstractMachine.Abs m) =
12.274 - AbstractMachine.Abs (rename (level+1) vars m)
12.275 -
12.276 - fun rename_guard (AbstractMachine.Guard (a,b)) =
12.277 - AbstractMachine.Guard (rename 0 vars a, rename 0 vars b)
12.278 - in
12.279 - ((encoding, hyptable, shyptable), (map rename_guard prems, pattern, rename 0 vars right))
12.280 - end
12.281 -
12.282 - val ((encoding, hyptable, shyptable), rules) =
12.283 - fold_rev (fn th => fn (encoding_hyptable, rules) =>
12.284 - let
12.285 - val (encoding_hyptable, rule) = thm2rule encoding_hyptable th
12.286 - in (encoding_hyptable, rule::rules) end)
12.287 - ths ((encoding, Termtab.empty, Sorttab.empty), [])
12.288 -
12.289 - fun make_cache_pattern t (encoding, cache_patterns) =
12.290 - let
12.291 - val (encoding, a) = remove_types encoding t
12.292 - val (_,_,p) = make_pattern encoding 0 Inttab.empty a
12.293 - in
12.294 - (encoding, p::cache_patterns)
12.295 - end
12.296 -
12.297 - val (encoding, _) = fold_rev make_cache_pattern cache_pattern_terms (encoding, [])
12.298 -
12.299 - val prog =
12.300 - case machine of
12.301 - BARRAS => ProgBarras (AM_Interpreter.compile rules)
12.302 - | BARRAS_COMPILED => ProgBarrasC (AM_Compiler.compile rules)
12.303 - | HASKELL => ProgHaskell (AM_GHC.compile rules)
12.304 - | SML => ProgSML (AM_SML.compile rules)
12.305 -
12.306 - fun has_witness s = not (null (Sign.witness_sorts thy [] [s]))
12.307 -
12.308 - val shyptable = fold Sorttab.delete (filter has_witness (Sorttab.keys (shyptable))) shyptable
12.309 -
12.310 - in (Theory.check_thy thy, encoding, Termtab.keys hyptable, shyptable, prog, stamp, default_naming) end
12.311 -
12.312 -fun make_with_cache machine thy cache_patterns raw_thms =
12.313 - Computer (Unsynchronized.ref (SOME (make_internal machine thy (Unsynchronized.ref ()) Encode.empty cache_patterns raw_thms)))
12.314 -
12.315 -fun make machine thy raw_thms = make_with_cache machine thy [] raw_thms
12.316 -
12.317 -fun update_with_cache computer cache_patterns raw_thms =
12.318 - let
12.319 - val c = make_internal (machine_of_prog (prog_of computer)) (theory_of computer) (stamp_of computer)
12.320 - (encoding_of computer) cache_patterns raw_thms
12.321 - val _ = (ref_of computer) := SOME c
12.322 - in
12.323 - ()
12.324 - end
12.325 -
12.326 -fun update computer raw_thms = update_with_cache computer [] raw_thms
12.327 -
12.328 -fun runprog (ProgBarras p) = AM_Interpreter.run p
12.329 - | runprog (ProgBarrasC p) = AM_Compiler.run p
12.330 - | runprog (ProgHaskell p) = AM_GHC.run p
12.331 - | runprog (ProgSML p) = AM_SML.run p
12.332 -
12.333 -(* ------------------------------------------------------------------------------------- *)
12.334 -(* An oracle for exporting theorems; must only be accessible from inside this structure! *)
12.335 -(* ------------------------------------------------------------------------------------- *)
12.336 -
12.337 -fun merge_hyps hyps1 hyps2 =
12.338 -let
12.339 - fun add hyps tab = fold (fn h => fn tab => Termtab.update (h, ()) tab) hyps tab
12.340 -in
12.341 - Termtab.keys (add hyps2 (add hyps1 Termtab.empty))
12.342 -end
12.343 -
12.344 -fun add_shyps shyps tab = fold (fn h => fn tab => Sorttab.update (h, ()) tab) shyps tab
12.345 -
12.346 -fun merge_shyps shyps1 shyps2 = Sorttab.keys (add_shyps shyps2 (add_shyps shyps1 Sorttab.empty))
12.347 -
12.348 -val (_, export_oracle) = Context.>>> (Context.map_theory_result
12.349 - (Thm.add_oracle (@{binding compute}, fn (thy, hyps, shyps, prop) =>
12.350 - let
12.351 - val shyptab = add_shyps shyps Sorttab.empty
12.352 - fun delete s shyptab = Sorttab.delete s shyptab handle Sorttab.UNDEF _ => shyptab
12.353 - fun delete_term t shyptab = fold delete (Sorts.insert_term t []) shyptab
12.354 - fun has_witness s = not (null (Sign.witness_sorts thy [] [s]))
12.355 - val shyptab = fold Sorttab.delete (filter has_witness (Sorttab.keys (shyptab))) shyptab
12.356 - val shyps = if Sorttab.is_empty shyptab then [] else Sorttab.keys (fold delete_term (prop::hyps) shyptab)
12.357 - val _ =
12.358 - if not (null shyps) then
12.359 - raise Compute ("dangling sort hypotheses: " ^
12.360 - commas (map (Syntax.string_of_sort_global thy) shyps))
12.361 - else ()
12.362 - in
12.363 - Thm.cterm_of thy (fold_rev (fn hyp => fn p => Logic.mk_implies (hyp, p)) hyps prop)
12.364 - end)));
12.365 -
12.366 -fun export_thm thy hyps shyps prop =
12.367 - let
12.368 - val th = export_oracle (thy, hyps, shyps, prop)
12.369 - val hyps = map (fn h => Thm.assume (cterm_of thy h)) hyps
12.370 - in
12.371 - fold (fn h => fn p => Thm.implies_elim p h) hyps th
12.372 - end
12.373 -
12.374 -(* --------- Rewrite ----------- *)
12.375 -
12.376 -fun rewrite computer ct =
12.377 - let
12.378 - val thy = Thm.theory_of_cterm ct
12.379 - val {t=t',T=ty,...} = rep_cterm ct
12.380 - val _ = Theory.assert_super (theory_of computer) thy
12.381 - val naming = naming_of computer
12.382 - val (encoding, t) = remove_types (encoding_of computer) t'
12.383 - val t = runprog (prog_of computer) t
12.384 - val t = infer_types naming encoding ty t
12.385 - val eq = Logic.mk_equals (t', t)
12.386 - in
12.387 - export_thm thy (hyps_of computer) (Sorttab.keys (shyptab_of computer)) eq
12.388 - end
12.389 -
12.390 -(* --------- Simplify ------------ *)
12.391 -
12.392 -datatype prem = EqPrem of AbstractMachine.term * AbstractMachine.term * Term.typ * int
12.393 - | Prem of AbstractMachine.term
12.394 -datatype theorem = Theorem of theory_ref * unit Unsynchronized.ref * (int * typ) Symtab.table * (AbstractMachine.term option) Inttab.table
12.395 - * prem list * AbstractMachine.term * term list * sort list
12.396 -
12.397 -
12.398 -exception ParamSimplify of computer * theorem
12.399 -
12.400 -fun make_theorem computer th vars =
12.401 -let
12.402 - val _ = Theory.assert_super (theory_of computer) (theory_of_thm th)
12.403 -
12.404 - val (ComputeThm (hyps, shyps, prop)) = thm2cthm th
12.405 -
12.406 - val encoding = encoding_of computer
12.407 -
12.408 - (* variables in the theorem are identified upfront *)
12.409 - fun collect_vars (Abs (_, _, t)) tab = collect_vars t tab
12.410 - | collect_vars (a $ b) tab = collect_vars b (collect_vars a tab)
12.411 - | collect_vars (Const _) tab = tab
12.412 - | collect_vars (Free _) tab = tab
12.413 - | collect_vars (Var ((s, i), ty)) tab =
12.414 - if List.find (fn x => x=s) vars = NONE then
12.415 - tab
12.416 - else
12.417 - (case Symtab.lookup tab s of
12.418 - SOME ((s',i'),ty') =>
12.419 - if s' <> s orelse i' <> i orelse ty <> ty' then
12.420 - raise Compute ("make_theorem: variable name '"^s^"' is not unique")
12.421 - else
12.422 - tab
12.423 - | NONE => Symtab.update (s, ((s, i), ty)) tab)
12.424 - val vartab = collect_vars prop Symtab.empty
12.425 - fun encodevar (s, t as (_, ty)) (encoding, tab) =
12.426 - let
12.427 - val (x, encoding) = Encode.insert (Var t) encoding
12.428 - in
12.429 - (encoding, Symtab.update (s, (x, ty)) tab)
12.430 - end
12.431 - val (encoding, vartab) = Symtab.fold encodevar vartab (encoding, Symtab.empty)
12.432 - val varsubst = Inttab.make (map (fn (_, (x, _)) => (x, NONE)) (Symtab.dest vartab))
12.433 -
12.434 - (* make the premises and the conclusion *)
12.435 - fun mk_prem encoding t =
12.436 - (let
12.437 - val (a, b) = Logic.dest_equals t
12.438 - val ty = type_of a
12.439 - val (encoding, a) = remove_types encoding a
12.440 - val (encoding, b) = remove_types encoding b
12.441 - val (eq, encoding) = Encode.insert (Const ("==", ty --> ty --> @{typ "prop"})) encoding
12.442 - in
12.443 - (encoding, EqPrem (a, b, ty, eq))
12.444 - end handle TERM _ => let val (encoding, t) = remove_types encoding t in (encoding, Prem t) end)
12.445 - val (encoding, prems) =
12.446 - (fold_rev (fn t => fn (encoding, l) =>
12.447 - case mk_prem encoding t of
12.448 - (encoding, t) => (encoding, t::l)) (Logic.strip_imp_prems prop) (encoding, []))
12.449 - val (encoding, concl) = remove_types encoding (Logic.strip_imp_concl prop)
12.450 - val _ = set_encoding computer encoding
12.451 -in
12.452 - Theorem (Theory.check_thy (theory_of_thm th), stamp_of computer, vartab, varsubst,
12.453 - prems, concl, hyps, shyps)
12.454 -end
12.455 -
12.456 -fun theory_of_theorem (Theorem (rthy,_,_,_,_,_,_,_)) = Theory.deref rthy
12.457 -fun update_theory thy (Theorem (_,p0,p1,p2,p3,p4,p5,p6)) =
12.458 - Theorem (Theory.check_thy thy,p0,p1,p2,p3,p4,p5,p6)
12.459 -fun stamp_of_theorem (Theorem (_,s, _, _, _, _, _, _)) = s
12.460 -fun vartab_of_theorem (Theorem (_,_,vt,_,_,_,_,_)) = vt
12.461 -fun varsubst_of_theorem (Theorem (_,_,_,vs,_,_,_,_)) = vs
12.462 -fun update_varsubst vs (Theorem (p0,p1,p2,_,p3,p4,p5,p6)) = Theorem (p0,p1,p2,vs,p3,p4,p5,p6)
12.463 -fun prems_of_theorem (Theorem (_,_,_,_,prems,_,_,_)) = prems
12.464 -fun update_prems prems (Theorem (p0,p1,p2,p3,_,p4,p5,p6)) = Theorem (p0,p1,p2,p3,prems,p4,p5,p6)
12.465 -fun concl_of_theorem (Theorem (_,_,_,_,_,concl,_,_)) = concl
12.466 -fun hyps_of_theorem (Theorem (_,_,_,_,_,_,hyps,_)) = hyps
12.467 -fun update_hyps hyps (Theorem (p0,p1,p2,p3,p4,p5,_,p6)) = Theorem (p0,p1,p2,p3,p4,p5,hyps,p6)
12.468 -fun shyps_of_theorem (Theorem (_,_,_,_,_,_,_,shyps)) = shyps
12.469 -fun update_shyps shyps (Theorem (p0,p1,p2,p3,p4,p5,p6,_)) = Theorem (p0,p1,p2,p3,p4,p5,p6,shyps)
12.470 -
12.471 -fun check_compatible computer th s =
12.472 - if stamp_of computer <> stamp_of_theorem th then
12.473 - raise Compute (s^": computer and theorem are incompatible")
12.474 - else ()
12.475 -
12.476 -fun instantiate computer insts th =
12.477 -let
12.478 - val _ = check_compatible computer th
12.479 -
12.480 - val thy = theory_of computer
12.481 -
12.482 - val vartab = vartab_of_theorem th
12.483 -
12.484 - fun rewrite computer t =
12.485 - let
12.486 - val (encoding, t) = remove_types (encoding_of computer) t
12.487 - val t = runprog (prog_of computer) t
12.488 - val _ = set_encoding computer encoding
12.489 - in
12.490 - t
12.491 - end
12.492 -
12.493 - fun assert_varfree vs t =
12.494 - if AbstractMachine.forall_consts (fn x => Inttab.lookup vs x = NONE) t then
12.495 - ()
12.496 - else
12.497 - raise Compute "instantiate: assert_varfree failed"
12.498 -
12.499 - fun assert_closed t =
12.500 - if AbstractMachine.closed t then
12.501 - ()
12.502 - else
12.503 - raise Compute "instantiate: not a closed term"
12.504 -
12.505 - fun compute_inst (s, ct) vs =
12.506 - let
12.507 - val _ = Theory.assert_super (theory_of_cterm ct) thy
12.508 - val ty = typ_of (ctyp_of_term ct)
12.509 - in
12.510 - (case Symtab.lookup vartab s of
12.511 - NONE => raise Compute ("instantiate: variable '"^s^"' not found in theorem")
12.512 - | SOME (x, ty') =>
12.513 - (case Inttab.lookup vs x of
12.514 - SOME (SOME _) => raise Compute ("instantiate: variable '"^s^"' has already been instantiated")
12.515 - | SOME NONE =>
12.516 - if ty <> ty' then
12.517 - raise Compute ("instantiate: wrong type for variable '"^s^"'")
12.518 - else
12.519 - let
12.520 - val t = rewrite computer (term_of ct)
12.521 - val _ = assert_varfree vs t
12.522 - val _ = assert_closed t
12.523 - in
12.524 - Inttab.update (x, SOME t) vs
12.525 - end
12.526 - | NONE => raise Compute "instantiate: internal error"))
12.527 - end
12.528 -
12.529 - val vs = fold compute_inst insts (varsubst_of_theorem th)
12.530 -in
12.531 - update_varsubst vs th
12.532 -end
12.533 -
12.534 -fun match_aterms subst =
12.535 - let
12.536 - exception no_match
12.537 - open AbstractMachine
12.538 - fun match subst (b as (Const c)) a =
12.539 - if a = b then subst
12.540 - else
12.541 - (case Inttab.lookup subst c of
12.542 - SOME (SOME a') => if a=a' then subst else raise no_match
12.543 - | SOME NONE => if AbstractMachine.closed a then
12.544 - Inttab.update (c, SOME a) subst
12.545 - else raise no_match
12.546 - | NONE => raise no_match)
12.547 - | match subst (b as (Var _)) a = if a=b then subst else raise no_match
12.548 - | match subst (App (u, v)) (App (u', v')) = match (match subst u u') v v'
12.549 - | match subst (Abs u) (Abs u') = match subst u u'
12.550 - | match subst _ _ = raise no_match
12.551 - in
12.552 - fn b => fn a => (SOME (match subst b a) handle no_match => NONE)
12.553 - end
12.554 -
12.555 -fun apply_subst vars_allowed subst =
12.556 - let
12.557 - open AbstractMachine
12.558 - fun app (t as (Const c)) =
12.559 - (case Inttab.lookup subst c of
12.560 - NONE => t
12.561 - | SOME (SOME t) => Computed t
12.562 - | SOME NONE => if vars_allowed then t else raise Compute "apply_subst: no vars allowed")
12.563 - | app (t as (Var _)) = t
12.564 - | app (App (u, v)) = App (app u, app v)
12.565 - | app (Abs m) = Abs (app m)
12.566 - in
12.567 - app
12.568 - end
12.569 -
12.570 -fun splicein n l L = List.take (L, n) @ l @ List.drop (L, n+1)
12.571 -
12.572 -fun evaluate_prem computer prem_no th =
12.573 -let
12.574 - val _ = check_compatible computer th
12.575 - val prems = prems_of_theorem th
12.576 - val varsubst = varsubst_of_theorem th
12.577 - fun run vars_allowed t =
12.578 - runprog (prog_of computer) (apply_subst vars_allowed varsubst t)
12.579 -in
12.580 - case nth prems prem_no of
12.581 - Prem _ => raise Compute "evaluate_prem: no equality premise"
12.582 - | EqPrem (a, b, ty, _) =>
12.583 - let
12.584 - val a' = run false a
12.585 - val b' = run true b
12.586 - in
12.587 - case match_aterms varsubst b' a' of
12.588 - NONE =>
12.589 - let
12.590 - fun mk s = Syntax.string_of_term_global Pure.thy
12.591 - (infer_types (naming_of computer) (encoding_of computer) ty s)
12.592 - val left = "computed left side: "^(mk a')
12.593 - val right = "computed right side: "^(mk b')
12.594 - in
12.595 - raise Compute ("evaluate_prem: cannot assign computed left to right hand side\n"^left^"\n"^right^"\n")
12.596 - end
12.597 - | SOME varsubst =>
12.598 - update_prems (splicein prem_no [] prems) (update_varsubst varsubst th)
12.599 - end
12.600 -end
12.601 -
12.602 -fun prem2term (Prem t) = t
12.603 - | prem2term (EqPrem (a,b,_,eq)) =
12.604 - AbstractMachine.App (AbstractMachine.App (AbstractMachine.Const eq, a), b)
12.605 -
12.606 -fun modus_ponens computer prem_no th' th =
12.607 -let
12.608 - val _ = check_compatible computer th
12.609 - val thy =
12.610 - let
12.611 - val thy1 = theory_of_theorem th
12.612 - val thy2 = theory_of_thm th'
12.613 - in
12.614 - if Theory.subthy (thy1, thy2) then thy2
12.615 - else if Theory.subthy (thy2, thy1) then thy1 else
12.616 - raise Compute "modus_ponens: theorems are not compatible with each other"
12.617 - end
12.618 - val th' = make_theorem computer th' []
12.619 - val varsubst = varsubst_of_theorem th
12.620 - fun run vars_allowed t =
12.621 - runprog (prog_of computer) (apply_subst vars_allowed varsubst t)
12.622 - val prems = prems_of_theorem th
12.623 - val prem = run true (prem2term (nth prems prem_no))
12.624 - val concl = run false (concl_of_theorem th')
12.625 -in
12.626 - case match_aterms varsubst prem concl of
12.627 - NONE => raise Compute "modus_ponens: conclusion does not match premise"
12.628 - | SOME varsubst =>
12.629 - let
12.630 - val th = update_varsubst varsubst th
12.631 - val th = update_prems (splicein prem_no (prems_of_theorem th') prems) th
12.632 - val th = update_hyps (merge_hyps (hyps_of_theorem th) (hyps_of_theorem th')) th
12.633 - val th = update_shyps (merge_shyps (shyps_of_theorem th) (shyps_of_theorem th')) th
12.634 - in
12.635 - update_theory thy th
12.636 - end
12.637 -end
12.638 -
12.639 -fun simplify computer th =
12.640 -let
12.641 - val _ = check_compatible computer th
12.642 - val varsubst = varsubst_of_theorem th
12.643 - val encoding = encoding_of computer
12.644 - val naming = naming_of computer
12.645 - fun infer t = infer_types naming encoding @{typ "prop"} t
12.646 - fun run t = infer (runprog (prog_of computer) (apply_subst true varsubst t))
12.647 - fun runprem p = run (prem2term p)
12.648 - val prop = Logic.list_implies (map runprem (prems_of_theorem th), run (concl_of_theorem th))
12.649 - val hyps = merge_hyps (hyps_of computer) (hyps_of_theorem th)
12.650 - val shyps = merge_shyps (shyps_of_theorem th) (Sorttab.keys (shyptab_of computer))
12.651 -in
12.652 - export_thm (theory_of_theorem th) hyps shyps prop
12.653 -end
12.654 -
12.655 -end
12.656 -
13.1 --- a/src/HOL/Matrix/Compute_Oracle/linker.ML Sat Mar 17 12:26:19 2012 +0100
13.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
13.3 @@ -1,470 +0,0 @@
13.4 -(* Title: HOL/Matrix/Compute_Oracle/linker.ML
13.5 - Author: Steven Obua
13.6 -
13.7 -This module solves the problem that the computing oracle does not
13.8 -instantiate polymorphic rules. By going through the PCompute
13.9 -interface, all possible instantiations are resolved by compiling new
13.10 -programs, if necessary. The obvious disadvantage of this approach is
13.11 -that in the worst case for each new term to be rewritten, a new
13.12 -program may be compiled.
13.13 -*)
13.14 -
13.15 -(*
13.16 - Given constants/frees c_1::t_1, c_2::t_2, ...., c_n::t_n,
13.17 - and constants/frees d_1::d_1, d_2::s_2, ..., d_m::s_m
13.18 -
13.19 - Find all substitutions S such that
13.20 - a) the domain of S is tvars (t_1, ..., t_n)
13.21 - b) there are indices i_1, ..., i_k, and j_1, ..., j_k with
13.22 - 1. S (c_i_1::t_i_1) = d_j_1::s_j_1, ..., S (c_i_k::t_i_k) = d_j_k::s_j_k
13.23 - 2. tvars (t_i_1, ..., t_i_k) = tvars (t_1, ..., t_n)
13.24 -*)
13.25 -signature LINKER =
13.26 -sig
13.27 - exception Link of string
13.28 -
13.29 - datatype constant = Constant of bool * string * typ
13.30 - val constant_of : term -> constant
13.31 -
13.32 - type instances
13.33 - type subst = Type.tyenv
13.34 -
13.35 - val empty : constant list -> instances
13.36 - val typ_of_constant : constant -> typ
13.37 - val add_instances : theory -> instances -> constant list -> subst list * instances
13.38 - val substs_of : instances -> subst list
13.39 - val is_polymorphic : constant -> bool
13.40 - val distinct_constants : constant list -> constant list
13.41 - val collect_consts : term list -> constant list
13.42 -end
13.43 -
13.44 -structure Linker : LINKER = struct
13.45 -
13.46 -exception Link of string;
13.47 -
13.48 -type subst = Type.tyenv
13.49 -
13.50 -datatype constant = Constant of bool * string * typ
13.51 -fun constant_of (Const (name, ty)) = Constant (false, name, ty)
13.52 - | constant_of (Free (name, ty)) = Constant (true, name, ty)
13.53 - | constant_of _ = raise Link "constant_of"
13.54 -
13.55 -fun bool_ord (x,y) = if x then (if y then EQUAL else GREATER) else (if y then LESS else EQUAL)
13.56 -fun constant_ord (Constant (x1,x2,x3), Constant (y1,y2,y3)) = (prod_ord (prod_ord bool_ord fast_string_ord) Term_Ord.typ_ord) (((x1,x2),x3), ((y1,y2),y3))
13.57 -fun constant_modty_ord (Constant (x1,x2,_), Constant (y1,y2,_)) = (prod_ord bool_ord fast_string_ord) ((x1,x2), (y1,y2))
13.58 -
13.59 -
13.60 -structure Consttab = Table(type key = constant val ord = constant_ord);
13.61 -structure ConsttabModTy = Table(type key = constant val ord = constant_modty_ord);
13.62 -
13.63 -fun typ_of_constant (Constant (_, _, ty)) = ty
13.64 -
13.65 -val empty_subst = (Vartab.empty : Type.tyenv)
13.66 -
13.67 -fun merge_subst (A:Type.tyenv) (B:Type.tyenv) =
13.68 - SOME (Vartab.fold (fn (v, t) =>
13.69 - fn tab =>
13.70 - (case Vartab.lookup tab v of
13.71 - NONE => Vartab.update (v, t) tab
13.72 - | SOME t' => if t = t' then tab else raise Type.TYPE_MATCH)) A B)
13.73 - handle Type.TYPE_MATCH => NONE
13.74 -
13.75 -fun subst_ord (A:Type.tyenv, B:Type.tyenv) =
13.76 - (list_ord (prod_ord Term_Ord.fast_indexname_ord (prod_ord Term_Ord.sort_ord Term_Ord.typ_ord))) (Vartab.dest A, Vartab.dest B)
13.77 -
13.78 -structure Substtab = Table(type key = Type.tyenv val ord = subst_ord);
13.79 -
13.80 -fun substtab_union c = Substtab.fold Substtab.update c
13.81 -fun substtab_unions [] = Substtab.empty
13.82 - | substtab_unions [c] = c
13.83 - | substtab_unions (c::cs) = substtab_union c (substtab_unions cs)
13.84 -
13.85 -datatype instances = Instances of unit ConsttabModTy.table * Type.tyenv Consttab.table Consttab.table * constant list list * unit Substtab.table
13.86 -
13.87 -fun is_polymorphic (Constant (_, _, ty)) = not (null (Term.add_tvarsT ty []))
13.88 -
13.89 -fun distinct_constants cs =
13.90 - Consttab.keys (fold (fn c => Consttab.update (c, ())) cs Consttab.empty)
13.91 -
13.92 -fun empty cs =
13.93 - let
13.94 - val cs = distinct_constants (filter is_polymorphic cs)
13.95 - val old_cs = cs
13.96 -(* fun collect_tvars ty tab = fold (fn v => fn tab => Typtab.update (TVar v, ()) tab) (Misc_Legacy.typ_tvars ty) tab
13.97 - val tvars_count = length (Typtab.keys (fold (fn c => fn tab => collect_tvars (typ_of_constant c) tab) cs Typtab.empty))
13.98 - fun tvars_of ty = collect_tvars ty Typtab.empty
13.99 - val cs = map (fn c => (c, tvars_of (typ_of_constant c))) cs
13.100 -
13.101 - fun tyunion A B =
13.102 - Typtab.fold
13.103 - (fn (v,()) => fn tab => Typtab.update (v, case Typtab.lookup tab v of NONE => 1 | SOME n => n+1) tab)
13.104 - A B
13.105 -
13.106 - fun is_essential A B =
13.107 - Typtab.fold
13.108 - (fn (v, ()) => fn essential => essential orelse (case Typtab.lookup B v of NONE => raise Link "is_essential" | SOME n => n=1))
13.109 - A false
13.110 -
13.111 - fun add_minimal (c', tvs') (tvs, cs) =
13.112 - let
13.113 - val tvs = tyunion tvs' tvs
13.114 - val cs = (c', tvs')::cs
13.115 - in
13.116 - if forall (fn (c',tvs') => is_essential tvs' tvs) cs then
13.117 - SOME (tvs, cs)
13.118 - else
13.119 - NONE
13.120 - end
13.121 -
13.122 - fun is_spanning (tvs, _) = (length (Typtab.keys tvs) = tvars_count)
13.123 -
13.124 - fun generate_minimal_subsets subsets [] = subsets
13.125 - | generate_minimal_subsets subsets (c::cs) =
13.126 - let
13.127 - val subsets' = map_filter (add_minimal c) subsets
13.128 - in
13.129 - generate_minimal_subsets (subsets@subsets') cs
13.130 - end*)
13.131 -
13.132 - val minimal_subsets = [old_cs] (*map (fn (tvs, cs) => map fst cs) (filter is_spanning (generate_minimal_subsets [(Typtab.empty, [])] cs))*)
13.133 -
13.134 - val constants = Consttab.keys (fold (fold (fn c => Consttab.update (c, ()))) minimal_subsets Consttab.empty)
13.135 -
13.136 - in
13.137 - Instances (
13.138 - fold (fn c => fn tab => ConsttabModTy.update (c, ()) tab) constants ConsttabModTy.empty,
13.139 - Consttab.make (map (fn c => (c, Consttab.empty : Type.tyenv Consttab.table)) constants),
13.140 - minimal_subsets, Substtab.empty)
13.141 - end
13.142 -
13.143 -local
13.144 -fun calc ctab substtab [] = substtab
13.145 - | calc ctab substtab (c::cs) =
13.146 - let
13.147 - val csubsts = map snd (Consttab.dest (the (Consttab.lookup ctab c)))
13.148 - fun merge_substs substtab subst =
13.149 - Substtab.fold (fn (s,_) =>
13.150 - fn tab =>
13.151 - (case merge_subst subst s of NONE => tab | SOME s => Substtab.update (s, ()) tab))
13.152 - substtab Substtab.empty
13.153 - val substtab = substtab_unions (map (merge_substs substtab) csubsts)
13.154 - in
13.155 - calc ctab substtab cs
13.156 - end
13.157 -in
13.158 -fun calc_substs ctab (cs:constant list) = calc ctab (Substtab.update (empty_subst, ()) Substtab.empty) cs
13.159 -end
13.160 -
13.161 -fun add_instances thy (Instances (cfilter, ctab,minsets,substs)) cs =
13.162 - let
13.163 -(* val _ = writeln (makestring ("add_instances: ", length_cs, length cs, length (Consttab.keys ctab)))*)
13.164 - fun calc_instantiations (constant as Constant (free, name, ty)) instantiations =
13.165 - Consttab.fold (fn (constant' as Constant (free', name', ty'), insttab) =>
13.166 - fn instantiations =>
13.167 - if free <> free' orelse name <> name' then
13.168 - instantiations
13.169 - else case Consttab.lookup insttab constant of
13.170 - SOME _ => instantiations
13.171 - | NONE => ((constant', (constant, Sign.typ_match thy (ty', ty) empty_subst))::instantiations
13.172 - handle Type.TYPE_MATCH => instantiations))
13.173 - ctab instantiations
13.174 - val instantiations = fold calc_instantiations cs []
13.175 - (*val _ = writeln ("instantiations = "^(makestring (length instantiations)))*)
13.176 - fun update_ctab (constant', entry) ctab =
13.177 - (case Consttab.lookup ctab constant' of
13.178 - NONE => raise Link "internal error: update_ctab"
13.179 - | SOME tab => Consttab.update (constant', Consttab.update entry tab) ctab)
13.180 - val ctab = fold update_ctab instantiations ctab
13.181 - val new_substs = fold (fn minset => fn substs => substtab_union (calc_substs ctab minset) substs)
13.182 - minsets Substtab.empty
13.183 - val (added_substs, substs) =
13.184 - Substtab.fold (fn (ns, _) =>
13.185 - fn (added, substtab) =>
13.186 - (case Substtab.lookup substs ns of
13.187 - NONE => (ns::added, Substtab.update (ns, ()) substtab)
13.188 - | SOME () => (added, substtab)))
13.189 - new_substs ([], substs)
13.190 - in
13.191 - (added_substs, Instances (cfilter, ctab, minsets, substs))
13.192 - end
13.193 -
13.194 -fun substs_of (Instances (_,_,_,substs)) = Substtab.keys substs
13.195 -
13.196 -
13.197 -local
13.198 -
13.199 -fun collect (Var _) tab = tab
13.200 - | collect (Bound _) tab = tab
13.201 - | collect (a $ b) tab = collect b (collect a tab)
13.202 - | collect (Abs (_, _, body)) tab = collect body tab
13.203 - | collect t tab = Consttab.update (constant_of t, ()) tab
13.204 -
13.205 -in
13.206 - fun collect_consts tms = Consttab.keys (fold collect tms Consttab.empty)
13.207 -end
13.208 -
13.209 -end
13.210 -
13.211 -signature PCOMPUTE =
13.212 -sig
13.213 - type pcomputer
13.214 -
13.215 - val make : Compute.machine -> theory -> thm list -> Linker.constant list -> pcomputer
13.216 - val make_with_cache : Compute.machine -> theory -> term list -> thm list -> Linker.constant list -> pcomputer
13.217 -
13.218 - val add_instances : pcomputer -> Linker.constant list -> bool
13.219 - val add_instances' : pcomputer -> term list -> bool
13.220 -
13.221 - val rewrite : pcomputer -> cterm list -> thm list
13.222 - val simplify : pcomputer -> Compute.theorem -> thm
13.223 -
13.224 - val make_theorem : pcomputer -> thm -> string list -> Compute.theorem
13.225 - val instantiate : pcomputer -> (string * cterm) list -> Compute.theorem -> Compute.theorem
13.226 - val evaluate_prem : pcomputer -> int -> Compute.theorem -> Compute.theorem
13.227 - val modus_ponens : pcomputer -> int -> thm -> Compute.theorem -> Compute.theorem
13.228 -
13.229 -end
13.230 -
13.231 -structure PCompute : PCOMPUTE = struct
13.232 -
13.233 -exception PCompute of string
13.234 -
13.235 -datatype theorem = MonoThm of thm | PolyThm of thm * Linker.instances * thm list
13.236 -datatype pattern = MonoPattern of term | PolyPattern of term * Linker.instances * term list
13.237 -
13.238 -datatype pcomputer =
13.239 - PComputer of theory_ref * Compute.computer * theorem list Unsynchronized.ref *
13.240 - pattern list Unsynchronized.ref
13.241 -
13.242 -(*fun collect_consts (Var x) = []
13.243 - | collect_consts (Bound _) = []
13.244 - | collect_consts (a $ b) = (collect_consts a)@(collect_consts b)
13.245 - | collect_consts (Abs (_, _, body)) = collect_consts body
13.246 - | collect_consts t = [Linker.constant_of t]*)
13.247 -
13.248 -fun computer_of (PComputer (_,computer,_,_)) = computer
13.249 -
13.250 -fun collect_consts_of_thm th =
13.251 - let
13.252 - val th = prop_of th
13.253 - val (prems, th) = (Logic.strip_imp_prems th, Logic.strip_imp_concl th)
13.254 - val (left, right) = Logic.dest_equals th
13.255 - in
13.256 - (Linker.collect_consts [left], Linker.collect_consts (right::prems))
13.257 - end
13.258 -
13.259 -fun create_theorem th =
13.260 -let
13.261 - val (left, right) = collect_consts_of_thm th
13.262 - val polycs = filter Linker.is_polymorphic left
13.263 - val tytab = fold (fn p => fn tab => fold (fn n => fn tab => Typtab.update (TVar n, ()) tab) (Misc_Legacy.typ_tvars (Linker.typ_of_constant p)) tab) polycs Typtab.empty
13.264 - fun check_const (c::cs) cs' =
13.265 - let
13.266 - val tvars = Misc_Legacy.typ_tvars (Linker.typ_of_constant c)
13.267 - val wrong = fold (fn n => fn wrong => wrong orelse is_none (Typtab.lookup tytab (TVar n))) tvars false
13.268 - in
13.269 - if wrong then raise PCompute "right hand side of theorem contains type variables which do not occur on the left hand side"
13.270 - else
13.271 - if null (tvars) then
13.272 - check_const cs (c::cs')
13.273 - else
13.274 - check_const cs cs'
13.275 - end
13.276 - | check_const [] cs' = cs'
13.277 - val monocs = check_const right []
13.278 -in
13.279 - if null (polycs) then
13.280 - (monocs, MonoThm th)
13.281 - else
13.282 - (monocs, PolyThm (th, Linker.empty polycs, []))
13.283 -end
13.284 -
13.285 -fun create_pattern pat =
13.286 -let
13.287 - val cs = Linker.collect_consts [pat]
13.288 - val polycs = filter Linker.is_polymorphic cs
13.289 -in
13.290 - if null (polycs) then
13.291 - MonoPattern pat
13.292 - else
13.293 - PolyPattern (pat, Linker.empty polycs, [])
13.294 -end
13.295 -
13.296 -fun create_computer machine thy pats ths =
13.297 - let
13.298 - fun add (MonoThm th) ths = th::ths
13.299 - | add (PolyThm (_, _, ths')) ths = ths'@ths
13.300 - fun addpat (MonoPattern p) pats = p::pats
13.301 - | addpat (PolyPattern (_, _, ps)) pats = ps@pats
13.302 - val ths = fold_rev add ths []
13.303 - val pats = fold_rev addpat pats []
13.304 - in
13.305 - Compute.make_with_cache machine thy pats ths
13.306 - end
13.307 -
13.308 -fun update_computer computer pats ths =
13.309 - let
13.310 - fun add (MonoThm th) ths = th::ths
13.311 - | add (PolyThm (_, _, ths')) ths = ths'@ths
13.312 - fun addpat (MonoPattern p) pats = p::pats
13.313 - | addpat (PolyPattern (_, _, ps)) pats = ps@pats
13.314 - val ths = fold_rev add ths []
13.315 - val pats = fold_rev addpat pats []
13.316 - in
13.317 - Compute.update_with_cache computer pats ths
13.318 - end
13.319 -
13.320 -fun conv_subst thy (subst : Type.tyenv) =
13.321 - map (fn (iname, (sort, ty)) => (ctyp_of thy (TVar (iname, sort)), ctyp_of thy ty)) (Vartab.dest subst)
13.322 -
13.323 -fun add_monos thy monocs pats ths =
13.324 - let
13.325 - val changed = Unsynchronized.ref false
13.326 - fun add monocs (th as (MonoThm _)) = ([], th)
13.327 - | add monocs (PolyThm (th, instances, instanceths)) =
13.328 - let
13.329 - val (newsubsts, instances) = Linker.add_instances thy instances monocs
13.330 - val _ = if not (null newsubsts) then changed := true else ()
13.331 - val newths = map (fn subst => Thm.instantiate (conv_subst thy subst, []) th) newsubsts
13.332 -(* val _ = if not (null newths) then (print ("added new theorems: ", newths); ()) else ()*)
13.333 - val newmonos = fold (fn th => fn monos => (snd (collect_consts_of_thm th))@monos) newths []
13.334 - in
13.335 - (newmonos, PolyThm (th, instances, instanceths@newths))
13.336 - end
13.337 - fun addpats monocs (pat as (MonoPattern _)) = pat
13.338 - | addpats monocs (PolyPattern (p, instances, instancepats)) =
13.339 - let
13.340 - val (newsubsts, instances) = Linker.add_instances thy instances monocs
13.341 - val _ = if not (null newsubsts) then changed := true else ()
13.342 - val newpats = map (fn subst => Envir.subst_term_types subst p) newsubsts
13.343 - in
13.344 - PolyPattern (p, instances, instancepats@newpats)
13.345 - end
13.346 - fun step monocs ths =
13.347 - fold_rev (fn th =>
13.348 - fn (newmonos, ths) =>
13.349 - let
13.350 - val (newmonos', th') = add monocs th
13.351 - in
13.352 - (newmonos'@newmonos, th'::ths)
13.353 - end)
13.354 - ths ([], [])
13.355 - fun loop monocs pats ths =
13.356 - let
13.357 - val (monocs', ths') = step monocs ths
13.358 - val pats' = map (addpats monocs) pats
13.359 - in
13.360 - if null (monocs') then
13.361 - (pats', ths')
13.362 - else
13.363 - loop monocs' pats' ths'
13.364 - end
13.365 - val result = loop monocs pats ths
13.366 - in
13.367 - (!changed, result)
13.368 - end
13.369 -
13.370 -datatype cthm = ComputeThm of term list * sort list * term
13.371 -
13.372 -fun thm2cthm th =
13.373 - let
13.374 - val {hyps, prop, shyps, ...} = Thm.rep_thm th
13.375 - in
13.376 - ComputeThm (hyps, shyps, prop)
13.377 - end
13.378 -
13.379 -val cthm_ord' = prod_ord (prod_ord (list_ord Term_Ord.term_ord) (list_ord Term_Ord.sort_ord)) Term_Ord.term_ord
13.380 -
13.381 -fun cthm_ord (ComputeThm (h1, sh1, p1), ComputeThm (h2, sh2, p2)) = cthm_ord' (((h1,sh1), p1), ((h2, sh2), p2))
13.382 -
13.383 -structure CThmtab = Table(type key = cthm val ord = cthm_ord)
13.384 -
13.385 -fun remove_duplicates ths =
13.386 - let
13.387 - val counter = Unsynchronized.ref 0
13.388 - val tab = Unsynchronized.ref (CThmtab.empty : unit CThmtab.table)
13.389 - val thstab = Unsynchronized.ref (Inttab.empty : thm Inttab.table)
13.390 - fun update th =
13.391 - let
13.392 - val key = thm2cthm th
13.393 - in
13.394 - case CThmtab.lookup (!tab) key of
13.395 - NONE => ((tab := CThmtab.update_new (key, ()) (!tab)); thstab := Inttab.update_new (!counter, th) (!thstab); counter := !counter + 1)
13.396 - | _ => ()
13.397 - end
13.398 - val _ = map update ths
13.399 - in
13.400 - map snd (Inttab.dest (!thstab))
13.401 - end
13.402 -
13.403 -fun make_with_cache machine thy pats ths cs =
13.404 - let
13.405 - val ths = remove_duplicates ths
13.406 - val (monocs, ths) = fold_rev (fn th =>
13.407 - fn (monocs, ths) =>
13.408 - let val (m, t) = create_theorem th in
13.409 - (m@monocs, t::ths)
13.410 - end)
13.411 - ths (cs, [])
13.412 - val pats = map create_pattern pats
13.413 - val (_, (pats, ths)) = add_monos thy monocs pats ths
13.414 - val computer = create_computer machine thy pats ths
13.415 - in
13.416 - PComputer (Theory.check_thy thy, computer, Unsynchronized.ref ths, Unsynchronized.ref pats)
13.417 - end
13.418 -
13.419 -fun make machine thy ths cs = make_with_cache machine thy [] ths cs
13.420 -
13.421 -fun add_instances (PComputer (thyref, computer, rths, rpats)) cs =
13.422 - let
13.423 - val thy = Theory.deref thyref
13.424 - val (changed, (pats, ths)) = add_monos thy cs (!rpats) (!rths)
13.425 - in
13.426 - if changed then
13.427 - (update_computer computer pats ths;
13.428 - rths := ths;
13.429 - rpats := pats;
13.430 - true)
13.431 - else
13.432 - false
13.433 -
13.434 - end
13.435 -
13.436 -fun add_instances' pc ts = add_instances pc (Linker.collect_consts ts)
13.437 -
13.438 -fun rewrite pc cts =
13.439 - let
13.440 - val _ = add_instances' pc (map term_of cts)
13.441 - val computer = (computer_of pc)
13.442 - in
13.443 - map (fn ct => Compute.rewrite computer ct) cts
13.444 - end
13.445 -
13.446 -fun simplify pc th = Compute.simplify (computer_of pc) th
13.447 -
13.448 -fun make_theorem pc th vars =
13.449 - let
13.450 - val _ = add_instances' pc [prop_of th]
13.451 -
13.452 - in
13.453 - Compute.make_theorem (computer_of pc) th vars
13.454 - end
13.455 -
13.456 -fun instantiate pc insts th =
13.457 - let
13.458 - val _ = add_instances' pc (map (term_of o snd) insts)
13.459 - in
13.460 - Compute.instantiate (computer_of pc) insts th
13.461 - end
13.462 -
13.463 -fun evaluate_prem pc prem_no th = Compute.evaluate_prem (computer_of pc) prem_no th
13.464 -
13.465 -fun modus_ponens pc prem_no th' th =
13.466 - let
13.467 - val _ = add_instances' pc [prop_of th']
13.468 - in
13.469 - Compute.modus_ponens (computer_of pc) prem_no th' th
13.470 - end
13.471 -
13.472 -
13.473 -end
14.1 --- a/src/HOL/Matrix/Compute_Oracle/report.ML Sat Mar 17 12:26:19 2012 +0100
14.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
14.3 @@ -1,33 +0,0 @@
14.4 -structure Report =
14.5 -struct
14.6 -
14.7 -local
14.8 -
14.9 - val report_depth = Unsynchronized.ref 0
14.10 - fun space n = if n <= 0 then "" else (space (n-1))^" "
14.11 - fun report_space () = space (!report_depth)
14.12 -
14.13 -in
14.14 -
14.15 -fun timeit f =
14.16 - let
14.17 - val t1 = Timing.start ()
14.18 - val x = f ()
14.19 - val t2 = Timing.message (Timing.result t1)
14.20 - val _ = writeln ((report_space ()) ^ "--> "^t2)
14.21 - in
14.22 - x
14.23 - end
14.24 -
14.25 -fun report s f =
14.26 -let
14.27 - val _ = writeln ((report_space ())^s)
14.28 - val _ = report_depth := !report_depth + 1
14.29 - val x = timeit f
14.30 - val _ = report_depth := !report_depth - 1
14.31 -in
14.32 - x
14.33 -end
14.34 -
14.35 -end
14.36 -end
14.37 \ No newline at end of file
15.1 --- a/src/HOL/Matrix/Cplex.thy Sat Mar 17 12:26:19 2012 +0100
15.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
15.3 @@ -1,67 +0,0 @@
15.4 -(* Title: HOL/Matrix/Cplex.thy
15.5 - Author: Steven Obua
15.6 -*)
15.7 -
15.8 -theory Cplex
15.9 -imports SparseMatrix LP ComputeFloat ComputeNumeral
15.10 -uses "Cplex_tools.ML" "CplexMatrixConverter.ML" "FloatSparseMatrixBuilder.ML"
15.11 - "fspmlp.ML" ("matrixlp.ML")
15.12 -begin
15.13 -
15.14 -lemma spm_mult_le_dual_prts:
15.15 - assumes
15.16 - "sorted_sparse_matrix A1"
15.17 - "sorted_sparse_matrix A2"
15.18 - "sorted_sparse_matrix c1"
15.19 - "sorted_sparse_matrix c2"
15.20 - "sorted_sparse_matrix y"
15.21 - "sorted_sparse_matrix r1"
15.22 - "sorted_sparse_matrix r2"
15.23 - "sorted_spvec b"
15.24 - "le_spmat [] y"
15.25 - "sparse_row_matrix A1 \<le> A"
15.26 - "A \<le> sparse_row_matrix A2"
15.27 - "sparse_row_matrix c1 \<le> c"
15.28 - "c \<le> sparse_row_matrix c2"
15.29 - "sparse_row_matrix r1 \<le> x"
15.30 - "x \<le> sparse_row_matrix r2"
15.31 - "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
15.32 - shows
15.33 - "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
15.34 - (let s1 = diff_spmat c1 (mult_spmat y A2); s2 = diff_spmat c2 (mult_spmat y A1) in
15.35 - add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
15.36 - (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))))"
15.37 - apply (simp add: Let_def)
15.38 - apply (insert assms)
15.39 - apply (simp add: sparse_row_matrix_op_simps algebra_simps)
15.40 - apply (rule mult_le_dual_prts[where A=A, simplified Let_def algebra_simps])
15.41 - apply (auto)
15.42 - done
15.43 -
15.44 -lemma spm_mult_le_dual_prts_no_let:
15.45 - assumes
15.46 - "sorted_sparse_matrix A1"
15.47 - "sorted_sparse_matrix A2"
15.48 - "sorted_sparse_matrix c1"
15.49 - "sorted_sparse_matrix c2"
15.50 - "sorted_sparse_matrix y"
15.51 - "sorted_sparse_matrix r1"
15.52 - "sorted_sparse_matrix r2"
15.53 - "sorted_spvec b"
15.54 - "le_spmat [] y"
15.55 - "sparse_row_matrix A1 \<le> A"
15.56 - "A \<le> sparse_row_matrix A2"
15.57 - "sparse_row_matrix c1 \<le> c"
15.58 - "c \<le> sparse_row_matrix c2"
15.59 - "sparse_row_matrix r1 \<le> x"
15.60 - "x \<le> sparse_row_matrix r2"
15.61 - "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
15.62 - shows
15.63 - "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
15.64 - (mult_est_spmat r1 r2 (diff_spmat c1 (mult_spmat y A2)) (diff_spmat c2 (mult_spmat y A1))))"
15.65 - by (simp add: assms mult_est_spmat_def spm_mult_le_dual_prts[where A=A, simplified Let_def])
15.66 -
15.67 -use "matrixlp.ML"
15.68 -
15.69 -end
15.70 -
16.1 --- a/src/HOL/Matrix/CplexMatrixConverter.ML Sat Mar 17 12:26:19 2012 +0100
16.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
16.3 @@ -1,128 +0,0 @@
16.4 -(* Title: HOL/Matrix/CplexMatrixConverter.ML
16.5 - Author: Steven Obua
16.6 -*)
16.7 -
16.8 -signature MATRIX_BUILDER =
16.9 -sig
16.10 - type vector
16.11 - type matrix
16.12 -
16.13 - val empty_vector : vector
16.14 - val empty_matrix : matrix
16.15 -
16.16 - exception Nat_expected of int
16.17 - val set_elem : vector -> int -> string -> vector
16.18 - val set_vector : matrix -> int -> vector -> matrix
16.19 -end;
16.20 -
16.21 -signature CPLEX_MATRIX_CONVERTER =
16.22 -sig
16.23 - structure cplex : CPLEX
16.24 - structure matrix_builder : MATRIX_BUILDER
16.25 - type vector = matrix_builder.vector
16.26 - type matrix = matrix_builder.matrix
16.27 - type naming = int * (int -> string) * (string -> int)
16.28 -
16.29 - exception Converter of string
16.30 -
16.31 - (* program must fulfill is_normed_cplexProg and must be an element of the image of elim_nonfree_bounds *)
16.32 - (* convert_prog maximize c A b naming *)
16.33 - val convert_prog : cplex.cplexProg -> bool * vector * matrix * vector * naming
16.34 -
16.35 - (* results must be optimal, converts_results returns the optimal value as string and the solution as vector *)
16.36 - (* convert_results results name2index *)
16.37 - val convert_results : cplex.cplexResult -> (string -> int) -> string * vector
16.38 -end;
16.39 -
16.40 -functor MAKE_CPLEX_MATRIX_CONVERTER (structure cplex: CPLEX and matrix_builder: MATRIX_BUILDER) : CPLEX_MATRIX_CONVERTER =
16.41 -struct
16.42 -
16.43 -structure cplex = cplex
16.44 -structure matrix_builder = matrix_builder
16.45 -type matrix = matrix_builder.matrix
16.46 -type vector = matrix_builder.vector
16.47 -type naming = int * (int -> string) * (string -> int)
16.48 -
16.49 -open matrix_builder
16.50 -open cplex
16.51 -
16.52 -exception Converter of string;
16.53 -
16.54 -fun neg_term (cplexNeg t) = t
16.55 - | neg_term (cplexSum ts) = cplexSum (map neg_term ts)
16.56 - | neg_term t = cplexNeg t
16.57 -
16.58 -fun convert_prog (cplexProg (_, goal, constrs, bounds)) =
16.59 - let
16.60 - fun build_naming index i2s s2i [] = (index, i2s, s2i)
16.61 - | build_naming index i2s s2i (cplexBounds (cplexNeg cplexInf, cplexLeq, cplexVar v, cplexLeq, cplexInf)::bounds)
16.62 - = build_naming (index+1) (Inttab.update (index, v) i2s) (Symtab.update_new (v, index) s2i) bounds
16.63 - | build_naming _ _ _ _ = raise (Converter "nonfree bound")
16.64 -
16.65 - val (varcount, i2s_tab, s2i_tab) = build_naming 0 Inttab.empty Symtab.empty bounds
16.66 -
16.67 - fun i2s i = case Inttab.lookup i2s_tab i of NONE => raise (Converter "index not found")
16.68 - | SOME n => n
16.69 - fun s2i s = case Symtab.lookup s2i_tab s of NONE => raise (Converter ("name not found: "^s))
16.70 - | SOME i => i
16.71 - fun num2str positive (cplexNeg t) = num2str (not positive) t
16.72 - | num2str positive (cplexNum num) = if positive then num else "-"^num
16.73 - | num2str _ _ = raise (Converter "term is not a (possibly signed) number")
16.74 -
16.75 - fun setprod vec positive (cplexNeg t) = setprod vec (not positive) t
16.76 - | setprod vec positive (cplexVar v) = set_elem vec (s2i v) (if positive then "1" else "-1")
16.77 - | setprod vec positive (cplexProd (cplexNum num, cplexVar v)) =
16.78 - set_elem vec (s2i v) (if positive then num else "-"^num)
16.79 - | setprod _ _ _ = raise (Converter "term is not a normed product")
16.80 -
16.81 - fun sum2vec (cplexSum ts) = fold (fn t => fn vec => setprod vec true t) ts empty_vector
16.82 - | sum2vec t = setprod empty_vector true t
16.83 -
16.84 - fun constrs2Ab j A b [] = (A, b)
16.85 - | constrs2Ab j A b ((_, cplexConstr (cplexLeq, (t1,t2)))::cs) =
16.86 - constrs2Ab (j+1) (set_vector A j (sum2vec t1)) (set_elem b j (num2str true t2)) cs
16.87 - | constrs2Ab j A b ((_, cplexConstr (cplexGeq, (t1,t2)))::cs) =
16.88 - constrs2Ab (j+1) (set_vector A j (sum2vec (neg_term t1))) (set_elem b j (num2str true (neg_term t2))) cs
16.89 - | constrs2Ab j A b ((_, cplexConstr (cplexEq, (t1,t2)))::cs) =
16.90 - constrs2Ab j A b ((NONE, cplexConstr (cplexLeq, (t1,t2)))::
16.91 - (NONE, cplexConstr (cplexGeq, (t1, t2)))::cs)
16.92 - | constrs2Ab _ _ _ _ = raise (Converter "no strict constraints allowed")
16.93 -
16.94 - val (A, b) = constrs2Ab 0 empty_matrix empty_vector constrs
16.95 -
16.96 - val (goal_maximize, goal_term) =
16.97 - case goal of
16.98 - (cplexMaximize t) => (true, t)
16.99 - | (cplexMinimize t) => (false, t)
16.100 - in
16.101 - (goal_maximize, sum2vec goal_term, A, b, (varcount, i2s, s2i))
16.102 - end
16.103 -
16.104 -fun convert_results (cplex.Optimal (opt, entries)) name2index =
16.105 - let
16.106 - fun setv (name, value) v = matrix_builder.set_elem v (name2index name) value
16.107 - in
16.108 - (opt, fold setv entries (matrix_builder.empty_vector))
16.109 - end
16.110 - | convert_results _ _ = raise (Converter "No optimal result")
16.111 -
16.112 -end;
16.113 -
16.114 -structure SimpleMatrixBuilder : MATRIX_BUILDER =
16.115 -struct
16.116 -type vector = (int * string) list
16.117 -type matrix = (int * vector) list
16.118 -
16.119 -val empty_matrix = []
16.120 -val empty_vector = []
16.121 -
16.122 -exception Nat_expected of int;
16.123 -
16.124 -fun set_elem v i s = v @ [(i, s)]
16.125 -
16.126 -fun set_vector m i v = m @ [(i, v)]
16.127 -
16.128 -end;
16.129 -
16.130 -structure SimpleCplexMatrixConverter =
16.131 - MAKE_CPLEX_MATRIX_CONVERTER(structure cplex = Cplex and matrix_builder = SimpleMatrixBuilder);
17.1 --- a/src/HOL/Matrix/Cplex_tools.ML Sat Mar 17 12:26:19 2012 +0100
17.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
17.3 @@ -1,1192 +0,0 @@
17.4 -(* Title: HOL/Matrix/Cplex_tools.ML
17.5 - Author: Steven Obua
17.6 -*)
17.7 -
17.8 -signature CPLEX =
17.9 -sig
17.10 -
17.11 - datatype cplexTerm = cplexVar of string | cplexNum of string | cplexInf
17.12 - | cplexNeg of cplexTerm
17.13 - | cplexProd of cplexTerm * cplexTerm
17.14 - | cplexSum of (cplexTerm list)
17.15 -
17.16 - datatype cplexComp = cplexLe | cplexLeq | cplexEq | cplexGe | cplexGeq
17.17 -
17.18 - datatype cplexGoal = cplexMinimize of cplexTerm
17.19 - | cplexMaximize of cplexTerm
17.20 -
17.21 - datatype cplexConstr = cplexConstr of cplexComp *
17.22 - (cplexTerm * cplexTerm)
17.23 -
17.24 - datatype cplexBounds = cplexBounds of cplexTerm * cplexComp * cplexTerm
17.25 - * cplexComp * cplexTerm
17.26 - | cplexBound of cplexTerm * cplexComp * cplexTerm
17.27 -
17.28 - datatype cplexProg = cplexProg of string
17.29 - * cplexGoal
17.30 - * ((string option * cplexConstr)
17.31 - list)
17.32 - * cplexBounds list
17.33 -
17.34 - datatype cplexResult = Unbounded
17.35 - | Infeasible
17.36 - | Undefined
17.37 - | Optimal of string *
17.38 - (((* name *) string *
17.39 - (* value *) string) list)
17.40 -
17.41 - datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK
17.42 -
17.43 - exception Load_cplexFile of string
17.44 - exception Load_cplexResult of string
17.45 - exception Save_cplexFile of string
17.46 - exception Execute of string
17.47 -
17.48 - val load_cplexFile : string -> cplexProg
17.49 -
17.50 - val save_cplexFile : string -> cplexProg -> unit
17.51 -
17.52 - val elim_nonfree_bounds : cplexProg -> cplexProg
17.53 -
17.54 - val relax_strict_ineqs : cplexProg -> cplexProg
17.55 -
17.56 - val is_normed_cplexProg : cplexProg -> bool
17.57 -
17.58 - val get_solver : unit -> cplexSolver
17.59 - val set_solver : cplexSolver -> unit
17.60 - val solve : cplexProg -> cplexResult
17.61 -end;
17.62 -
17.63 -structure Cplex : CPLEX =
17.64 -struct
17.65 -
17.66 -datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK
17.67 -
17.68 -val cplexsolver = Unsynchronized.ref SOLVER_DEFAULT;
17.69 -fun get_solver () = !cplexsolver;
17.70 -fun set_solver s = (cplexsolver := s);
17.71 -
17.72 -exception Load_cplexFile of string;
17.73 -exception Load_cplexResult of string;
17.74 -exception Save_cplexFile of string;
17.75 -
17.76 -datatype cplexTerm = cplexVar of string
17.77 - | cplexNum of string
17.78 - | cplexInf
17.79 - | cplexNeg of cplexTerm
17.80 - | cplexProd of cplexTerm * cplexTerm
17.81 - | cplexSum of (cplexTerm list)
17.82 -datatype cplexComp = cplexLe | cplexLeq | cplexEq | cplexGe | cplexGeq
17.83 -datatype cplexGoal = cplexMinimize of cplexTerm | cplexMaximize of cplexTerm
17.84 -datatype cplexConstr = cplexConstr of cplexComp * (cplexTerm * cplexTerm)
17.85 -datatype cplexBounds = cplexBounds of cplexTerm * cplexComp * cplexTerm
17.86 - * cplexComp * cplexTerm
17.87 - | cplexBound of cplexTerm * cplexComp * cplexTerm
17.88 -datatype cplexProg = cplexProg of string
17.89 - * cplexGoal
17.90 - * ((string option * cplexConstr) list)
17.91 - * cplexBounds list
17.92 -
17.93 -fun rev_cmp cplexLe = cplexGe
17.94 - | rev_cmp cplexLeq = cplexGeq
17.95 - | rev_cmp cplexGe = cplexLe
17.96 - | rev_cmp cplexGeq = cplexLeq
17.97 - | rev_cmp cplexEq = cplexEq
17.98 -
17.99 -fun the NONE = raise (Load_cplexFile "SOME expected")
17.100 - | the (SOME x) = x;
17.101 -
17.102 -fun modulo_signed is_something (cplexNeg u) = is_something u
17.103 - | modulo_signed is_something u = is_something u
17.104 -
17.105 -fun is_Num (cplexNum _) = true
17.106 - | is_Num _ = false
17.107 -
17.108 -fun is_Inf cplexInf = true
17.109 - | is_Inf _ = false
17.110 -
17.111 -fun is_Var (cplexVar _) = true
17.112 - | is_Var _ = false
17.113 -
17.114 -fun is_Neg (cplexNeg _) = true
17.115 - | is_Neg _ = false
17.116 -
17.117 -fun is_normed_Prod (cplexProd (t1, t2)) =
17.118 - (is_Num t1) andalso (is_Var t2)
17.119 - | is_normed_Prod x = is_Var x
17.120 -
17.121 -fun is_normed_Sum (cplexSum ts) =
17.122 - (ts <> []) andalso forall (modulo_signed is_normed_Prod) ts
17.123 - | is_normed_Sum x = modulo_signed is_normed_Prod x
17.124 -
17.125 -fun is_normed_Constr (cplexConstr (_, (t1, t2))) =
17.126 - (is_normed_Sum t1) andalso (modulo_signed is_Num t2)
17.127 -
17.128 -fun is_Num_or_Inf x = is_Inf x orelse is_Num x
17.129 -
17.130 -fun is_normed_Bounds (cplexBounds (t1, c1, t2, c2, t3)) =
17.131 - (c1 = cplexLe orelse c1 = cplexLeq) andalso
17.132 - (c2 = cplexLe orelse c2 = cplexLeq) andalso
17.133 - is_Var t2 andalso
17.134 - modulo_signed is_Num_or_Inf t1 andalso
17.135 - modulo_signed is_Num_or_Inf t3
17.136 - | is_normed_Bounds (cplexBound (t1, c, t2)) =
17.137 - (is_Var t1 andalso (modulo_signed is_Num_or_Inf t2))
17.138 - orelse
17.139 - (c <> cplexEq andalso
17.140 - is_Var t2 andalso (modulo_signed is_Num_or_Inf t1))
17.141 -
17.142 -fun term_of_goal (cplexMinimize x) = x
17.143 - | term_of_goal (cplexMaximize x) = x
17.144 -
17.145 -fun is_normed_cplexProg (cplexProg (_, goal, constraints, bounds)) =
17.146 - is_normed_Sum (term_of_goal goal) andalso
17.147 - forall (fn (_,x) => is_normed_Constr x) constraints andalso
17.148 - forall is_normed_Bounds bounds
17.149 -
17.150 -fun is_NL s = s = "\n"
17.151 -
17.152 -fun is_blank s = forall (fn c => c <> #"\n" andalso Char.isSpace c) (String.explode s)
17.153 -
17.154 -fun is_num a =
17.155 - let
17.156 - val b = String.explode a
17.157 - fun num4 cs = forall Char.isDigit cs
17.158 - fun num3 [] = true
17.159 - | num3 (ds as (c::cs)) =
17.160 - if c = #"+" orelse c = #"-" then
17.161 - num4 cs
17.162 - else
17.163 - num4 ds
17.164 - fun num2 [] = true
17.165 - | num2 (c::cs) =
17.166 - if c = #"e" orelse c = #"E" then num3 cs
17.167 - else (Char.isDigit c) andalso num2 cs
17.168 - fun num1 [] = true
17.169 - | num1 (c::cs) =
17.170 - if c = #"." then num2 cs
17.171 - else if c = #"e" orelse c = #"E" then num3 cs
17.172 - else (Char.isDigit c) andalso num1 cs
17.173 - fun num [] = true
17.174 - | num (c::cs) =
17.175 - if c = #"." then num2 cs
17.176 - else (Char.isDigit c) andalso num1 cs
17.177 - in
17.178 - num b
17.179 - end
17.180 -
17.181 -fun is_delimiter s = s = "+" orelse s = "-" orelse s = ":"
17.182 -
17.183 -fun is_cmp s = s = "<" orelse s = ">" orelse s = "<="
17.184 - orelse s = ">=" orelse s = "="
17.185 -
17.186 -fun is_symbol a =
17.187 - let
17.188 - val symbol_char = String.explode "!\"#$%&()/,.;?@_`'{}|~"
17.189 - fun is_symbol_char c = Char.isAlphaNum c orelse
17.190 - exists (fn d => d=c) symbol_char
17.191 - fun is_symbol_start c = is_symbol_char c andalso
17.192 - not (Char.isDigit c) andalso
17.193 - not (c= #".")
17.194 - val b = String.explode a
17.195 - in
17.196 - b <> [] andalso is_symbol_start (hd b) andalso
17.197 - forall is_symbol_char b
17.198 - end
17.199 -
17.200 -fun to_upper s = String.implode (map Char.toUpper (String.explode s))
17.201 -
17.202 -fun keyword x =
17.203 - let
17.204 - val a = to_upper x
17.205 - in
17.206 - if a = "BOUNDS" orelse a = "BOUND" then
17.207 - SOME "BOUNDS"
17.208 - else if a = "MINIMIZE" orelse a = "MINIMUM" orelse a = "MIN" then
17.209 - SOME "MINIMIZE"
17.210 - else if a = "MAXIMIZE" orelse a = "MAXIMUM" orelse a = "MAX" then
17.211 - SOME "MAXIMIZE"
17.212 - else if a = "ST" orelse a = "S.T." orelse a = "ST." then
17.213 - SOME "ST"
17.214 - else if a = "FREE" orelse a = "END" then
17.215 - SOME a
17.216 - else if a = "GENERAL" orelse a = "GENERALS" orelse a = "GEN" then
17.217 - SOME "GENERAL"
17.218 - else if a = "INTEGER" orelse a = "INTEGERS" orelse a = "INT" then
17.219 - SOME "INTEGER"
17.220 - else if a = "BINARY" orelse a = "BINARIES" orelse a = "BIN" then
17.221 - SOME "BINARY"
17.222 - else if a = "INF" orelse a = "INFINITY" then
17.223 - SOME "INF"
17.224 - else
17.225 - NONE
17.226 - end
17.227 -
17.228 -val TOKEN_ERROR = ~1
17.229 -val TOKEN_BLANK = 0
17.230 -val TOKEN_NUM = 1
17.231 -val TOKEN_DELIMITER = 2
17.232 -val TOKEN_SYMBOL = 3
17.233 -val TOKEN_LABEL = 4
17.234 -val TOKEN_CMP = 5
17.235 -val TOKEN_KEYWORD = 6
17.236 -val TOKEN_NL = 7
17.237 -
17.238 -(* tokenize takes a list of chars as argument and returns a list of
17.239 - int * string pairs, each string representing a "cplex token",
17.240 - and each int being one of TOKEN_NUM, TOKEN_DELIMITER, TOKEN_CMP
17.241 - or TOKEN_SYMBOL *)
17.242 -fun tokenize s =
17.243 - let
17.244 - val flist = [(is_NL, TOKEN_NL),
17.245 - (is_blank, TOKEN_BLANK),
17.246 - (is_num, TOKEN_NUM),
17.247 - (is_delimiter, TOKEN_DELIMITER),
17.248 - (is_cmp, TOKEN_CMP),
17.249 - (is_symbol, TOKEN_SYMBOL)]
17.250 - fun match_helper [] s = (fn _ => false, TOKEN_ERROR)
17.251 - | match_helper (f::fs) s =
17.252 - if ((fst f) s) then f else match_helper fs s
17.253 - fun match s = match_helper flist s
17.254 - fun tok s =
17.255 - if s = "" then [] else
17.256 - let
17.257 - val h = String.substring (s,0,1)
17.258 - val (f, j) = match h
17.259 - fun len i =
17.260 - if size s = i then i
17.261 - else if f (String.substring (s,0,i+1)) then
17.262 - len (i+1)
17.263 - else i
17.264 - in
17.265 - if j < 0 then
17.266 - (if h = "\\" then []
17.267 - else raise (Load_cplexFile ("token expected, found: "
17.268 - ^s)))
17.269 - else
17.270 - let
17.271 - val l = len 1
17.272 - val u = String.substring (s,0,l)
17.273 - val v = String.extract (s,l,NONE)
17.274 - in
17.275 - if j = 0 then tok v else (j, u) :: tok v
17.276 - end
17.277 - end
17.278 - in
17.279 - tok s
17.280 - end
17.281 -
17.282 -exception Tokenize of string;
17.283 -
17.284 -fun tokenize_general flist s =
17.285 - let
17.286 - fun match_helper [] s = raise (Tokenize s)
17.287 - | match_helper (f::fs) s =
17.288 - if ((fst f) s) then f else match_helper fs s
17.289 - fun match s = match_helper flist s
17.290 - fun tok s =
17.291 - if s = "" then [] else
17.292 - let
17.293 - val h = String.substring (s,0,1)
17.294 - val (f, j) = match h
17.295 - fun len i =
17.296 - if size s = i then i
17.297 - else if f (String.substring (s,0,i+1)) then
17.298 - len (i+1)
17.299 - else i
17.300 - val l = len 1
17.301 - in
17.302 - (j, String.substring (s,0,l)) :: tok (String.extract (s,l,NONE))
17.303 - end
17.304 - in
17.305 - tok s
17.306 - end
17.307 -
17.308 -fun load_cplexFile name =
17.309 - let
17.310 - val f = TextIO.openIn name
17.311 - val ignore_NL = Unsynchronized.ref true
17.312 - val rest = Unsynchronized.ref []
17.313 -
17.314 - fun is_symbol s c = (fst c) = TOKEN_SYMBOL andalso (to_upper (snd c)) = s
17.315 -
17.316 - fun readToken_helper () =
17.317 - if length (!rest) > 0 then
17.318 - let val u = hd (!rest) in
17.319 - (
17.320 - rest := tl (!rest);
17.321 - SOME u
17.322 - )
17.323 - end
17.324 - else
17.325 - (case TextIO.inputLine f of
17.326 - NONE => NONE
17.327 - | SOME s =>
17.328 - let val t = tokenize s in
17.329 - if (length t >= 2 andalso
17.330 - snd(hd (tl t)) = ":")
17.331 - then
17.332 - rest := (TOKEN_LABEL, snd (hd t)) :: (tl (tl t))
17.333 - else if (length t >= 2) andalso is_symbol "SUBJECT" (hd (t))
17.334 - andalso is_symbol "TO" (hd (tl t))
17.335 - then
17.336 - rest := (TOKEN_SYMBOL, "ST") :: (tl (tl t))
17.337 - else
17.338 - rest := t;
17.339 - readToken_helper ()
17.340 - end)
17.341 -
17.342 - fun readToken_helper2 () =
17.343 - let val c = readToken_helper () in
17.344 - if c = NONE then NONE
17.345 - else if !ignore_NL andalso fst (the c) = TOKEN_NL then
17.346 - readToken_helper2 ()
17.347 - else if fst (the c) = TOKEN_SYMBOL
17.348 - andalso keyword (snd (the c)) <> NONE
17.349 - then SOME (TOKEN_KEYWORD, the (keyword (snd (the c))))
17.350 - else c
17.351 - end
17.352 -
17.353 - fun readToken () = readToken_helper2 ()
17.354 -
17.355 - fun pushToken a = rest := (a::(!rest))
17.356 -
17.357 - fun is_value token =
17.358 - fst token = TOKEN_NUM orelse (fst token = TOKEN_KEYWORD
17.359 - andalso snd token = "INF")
17.360 -
17.361 - fun get_value token =
17.362 - if fst token = TOKEN_NUM then
17.363 - cplexNum (snd token)
17.364 - else if fst token = TOKEN_KEYWORD andalso snd token = "INF"
17.365 - then
17.366 - cplexInf
17.367 - else
17.368 - raise (Load_cplexFile "num expected")
17.369 -
17.370 - fun readTerm_Product only_num =
17.371 - let val c = readToken () in
17.372 - if c = NONE then NONE
17.373 - else if fst (the c) = TOKEN_SYMBOL
17.374 - then (
17.375 - if only_num then (pushToken (the c); NONE)
17.376 - else SOME (cplexVar (snd (the c)))
17.377 - )
17.378 - else if only_num andalso is_value (the c) then
17.379 - SOME (get_value (the c))
17.380 - else if is_value (the c) then
17.381 - let val t1 = get_value (the c)
17.382 - val d = readToken ()
17.383 - in
17.384 - if d = NONE then SOME t1
17.385 - else if fst (the d) = TOKEN_SYMBOL then
17.386 - SOME (cplexProd (t1, cplexVar (snd (the d))))
17.387 - else
17.388 - (pushToken (the d); SOME t1)
17.389 - end
17.390 - else (pushToken (the c); NONE)
17.391 - end
17.392 -
17.393 - fun readTerm_Signed only_signed only_num =
17.394 - let
17.395 - val c = readToken ()
17.396 - in
17.397 - if c = NONE then NONE
17.398 - else
17.399 - let val d = the c in
17.400 - if d = (TOKEN_DELIMITER, "+") then
17.401 - readTerm_Product only_num
17.402 - else if d = (TOKEN_DELIMITER, "-") then
17.403 - SOME (cplexNeg (the (readTerm_Product
17.404 - only_num)))
17.405 - else (pushToken d;
17.406 - if only_signed then NONE
17.407 - else readTerm_Product only_num)
17.408 - end
17.409 - end
17.410 -
17.411 - fun readTerm_Sum first_signed =
17.412 - let val c = readTerm_Signed first_signed false in
17.413 - if c = NONE then [] else (the c)::(readTerm_Sum true)
17.414 - end
17.415 -
17.416 - fun readTerm () =
17.417 - let val c = readTerm_Sum false in
17.418 - if c = [] then NONE
17.419 - else if tl c = [] then SOME (hd c)
17.420 - else SOME (cplexSum c)
17.421 - end
17.422 -
17.423 - fun readLabeledTerm () =
17.424 - let val c = readToken () in
17.425 - if c = NONE then (NONE, NONE)
17.426 - else if fst (the c) = TOKEN_LABEL then
17.427 - let val t = readTerm () in
17.428 - if t = NONE then
17.429 - raise (Load_cplexFile ("term after label "^
17.430 - (snd (the c))^
17.431 - " expected"))
17.432 - else (SOME (snd (the c)), t)
17.433 - end
17.434 - else (pushToken (the c); (NONE, readTerm ()))
17.435 - end
17.436 -
17.437 - fun readGoal () =
17.438 - let
17.439 - val g = readToken ()
17.440 - in
17.441 - if g = SOME (TOKEN_KEYWORD, "MAXIMIZE") then
17.442 - cplexMaximize (the (snd (readLabeledTerm ())))
17.443 - else if g = SOME (TOKEN_KEYWORD, "MINIMIZE") then
17.444 - cplexMinimize (the (snd (readLabeledTerm ())))
17.445 - else raise (Load_cplexFile "MAXIMIZE or MINIMIZE expected")
17.446 - end
17.447 -
17.448 - fun str2cmp b =
17.449 - (case b of
17.450 - "<" => cplexLe
17.451 - | "<=" => cplexLeq
17.452 - | ">" => cplexGe
17.453 - | ">=" => cplexGeq
17.454 - | "=" => cplexEq
17.455 - | _ => raise (Load_cplexFile (b^" is no TOKEN_CMP")))
17.456 -
17.457 - fun readConstraint () =
17.458 - let
17.459 - val t = readLabeledTerm ()
17.460 - fun make_constraint b t1 t2 =
17.461 - cplexConstr
17.462 - (str2cmp b,
17.463 - (t1, t2))
17.464 - in
17.465 - if snd t = NONE then NONE
17.466 - else
17.467 - let val c = readToken () in
17.468 - if c = NONE orelse fst (the c) <> TOKEN_CMP
17.469 - then raise (Load_cplexFile "TOKEN_CMP expected")
17.470 - else
17.471 - let val n = readTerm_Signed false true in
17.472 - if n = NONE then
17.473 - raise (Load_cplexFile "num expected")
17.474 - else
17.475 - SOME (fst t,
17.476 - make_constraint (snd (the c))
17.477 - (the (snd t))
17.478 - (the n))
17.479 - end
17.480 - end
17.481 - end
17.482 -
17.483 - fun readST () =
17.484 - let
17.485 - fun readbody () =
17.486 - let val t = readConstraint () in
17.487 - if t = NONE then []
17.488 - else if (is_normed_Constr (snd (the t))) then
17.489 - (the t)::(readbody ())
17.490 - else if (fst (the t) <> NONE) then
17.491 - raise (Load_cplexFile
17.492 - ("constraint '"^(the (fst (the t)))^
17.493 - "'is not normed"))
17.494 - else
17.495 - raise (Load_cplexFile
17.496 - "constraint is not normed")
17.497 - end
17.498 - in
17.499 - if readToken () = SOME (TOKEN_KEYWORD, "ST")
17.500 - then
17.501 - readbody ()
17.502 - else
17.503 - raise (Load_cplexFile "ST expected")
17.504 - end
17.505 -
17.506 - fun readCmp () =
17.507 - let val c = readToken () in
17.508 - if c = NONE then NONE
17.509 - else if fst (the c) = TOKEN_CMP then
17.510 - SOME (str2cmp (snd (the c)))
17.511 - else (pushToken (the c); NONE)
17.512 - end
17.513 -
17.514 - fun skip_NL () =
17.515 - let val c = readToken () in
17.516 - if c <> NONE andalso fst (the c) = TOKEN_NL then
17.517 - skip_NL ()
17.518 - else
17.519 - (pushToken (the c); ())
17.520 - end
17.521 -
17.522 - fun make_bounds c t1 t2 =
17.523 - cplexBound (t1, c, t2)
17.524 -
17.525 - fun readBound () =
17.526 - let
17.527 - val _ = skip_NL ()
17.528 - val t1 = readTerm ()
17.529 - in
17.530 - if t1 = NONE then NONE
17.531 - else
17.532 - let
17.533 - val c1 = readCmp ()
17.534 - in
17.535 - if c1 = NONE then
17.536 - let
17.537 - val c = readToken ()
17.538 - in
17.539 - if c = SOME (TOKEN_KEYWORD, "FREE") then
17.540 - SOME (
17.541 - cplexBounds (cplexNeg cplexInf,
17.542 - cplexLeq,
17.543 - the t1,
17.544 - cplexLeq,
17.545 - cplexInf))
17.546 - else
17.547 - raise (Load_cplexFile "FREE expected")
17.548 - end
17.549 - else
17.550 - let
17.551 - val t2 = readTerm ()
17.552 - in
17.553 - if t2 = NONE then
17.554 - raise (Load_cplexFile "term expected")
17.555 - else
17.556 - let val c2 = readCmp () in
17.557 - if c2 = NONE then
17.558 - SOME (make_bounds (the c1)
17.559 - (the t1)
17.560 - (the t2))
17.561 - else
17.562 - SOME (
17.563 - cplexBounds (the t1,
17.564 - the c1,
17.565 - the t2,
17.566 - the c2,
17.567 - the (readTerm())))
17.568 - end
17.569 - end
17.570 - end
17.571 - end
17.572 -
17.573 - fun readBounds () =
17.574 - let
17.575 - fun makestring _ = "?"
17.576 - fun readbody () =
17.577 - let
17.578 - val b = readBound ()
17.579 - in
17.580 - if b = NONE then []
17.581 - else if (is_normed_Bounds (the b)) then
17.582 - (the b)::(readbody())
17.583 - else (
17.584 - raise (Load_cplexFile
17.585 - ("bounds are not normed in: "^
17.586 - (makestring (the b)))))
17.587 - end
17.588 - in
17.589 - if readToken () = SOME (TOKEN_KEYWORD, "BOUNDS") then
17.590 - readbody ()
17.591 - else raise (Load_cplexFile "BOUNDS expected")
17.592 - end
17.593 -
17.594 - fun readEnd () =
17.595 - if readToken () = SOME (TOKEN_KEYWORD, "END") then ()
17.596 - else raise (Load_cplexFile "END expected")
17.597 -
17.598 - val result_Goal = readGoal ()
17.599 - val result_ST = readST ()
17.600 - val _ = ignore_NL := false
17.601 - val result_Bounds = readBounds ()
17.602 - val _ = ignore_NL := true
17.603 - val _ = readEnd ()
17.604 - val _ = TextIO.closeIn f
17.605 - in
17.606 - cplexProg (name, result_Goal, result_ST, result_Bounds)
17.607 - end
17.608 -
17.609 -fun save_cplexFile filename (cplexProg (_, goal, constraints, bounds)) =
17.610 - let
17.611 - val f = TextIO.openOut filename
17.612 -
17.613 - fun basic_write s = TextIO.output(f, s)
17.614 -
17.615 - val linebuf = Unsynchronized.ref ""
17.616 - fun buf_flushline s =
17.617 - (basic_write (!linebuf);
17.618 - basic_write "\n";
17.619 - linebuf := s)
17.620 - fun buf_add s = linebuf := (!linebuf) ^ s
17.621 -
17.622 - fun write s =
17.623 - if (String.size s) + (String.size (!linebuf)) >= 250 then
17.624 - buf_flushline (" "^s)
17.625 - else
17.626 - buf_add s
17.627 -
17.628 - fun writeln s = (buf_add s; buf_flushline "")
17.629 -
17.630 - fun write_term (cplexVar x) = write x
17.631 - | write_term (cplexNum x) = write x
17.632 - | write_term cplexInf = write "inf"
17.633 - | write_term (cplexProd (cplexNum "1", b)) = write_term b
17.634 - | write_term (cplexProd (a, b)) =
17.635 - (write_term a; write " "; write_term b)
17.636 - | write_term (cplexNeg x) = (write " - "; write_term x)
17.637 - | write_term (cplexSum ts) = write_terms ts
17.638 - and write_terms [] = ()
17.639 - | write_terms (t::ts) =
17.640 - (if (not (is_Neg t)) then write " + " else ();
17.641 - write_term t; write_terms ts)
17.642 -
17.643 - fun write_goal (cplexMaximize term) =
17.644 - (writeln "MAXIMIZE"; write_term term; writeln "")
17.645 - | write_goal (cplexMinimize term) =
17.646 - (writeln "MINIMIZE"; write_term term; writeln "")
17.647 -
17.648 - fun write_cmp cplexLe = write "<"
17.649 - | write_cmp cplexLeq = write "<="
17.650 - | write_cmp cplexEq = write "="
17.651 - | write_cmp cplexGe = write ">"
17.652 - | write_cmp cplexGeq = write ">="
17.653 -
17.654 - fun write_constr (cplexConstr (cmp, (a,b))) =
17.655 - (write_term a;
17.656 - write " ";
17.657 - write_cmp cmp;
17.658 - write " ";
17.659 - write_term b)
17.660 -
17.661 - fun write_constraints [] = ()
17.662 - | write_constraints (c::cs) =
17.663 - (if (fst c <> NONE)
17.664 - then
17.665 - (write (the (fst c)); write ": ")
17.666 - else
17.667 - ();
17.668 - write_constr (snd c);
17.669 - writeln "";
17.670 - write_constraints cs)
17.671 -
17.672 - fun write_bounds [] = ()
17.673 - | write_bounds ((cplexBounds (t1,c1,t2,c2,t3))::bs) =
17.674 - ((if t1 = cplexNeg cplexInf andalso t3 = cplexInf
17.675 - andalso (c1 = cplexLeq orelse c1 = cplexLe)
17.676 - andalso (c2 = cplexLeq orelse c2 = cplexLe)
17.677 - then
17.678 - (write_term t2; write " free")
17.679 - else
17.680 - (write_term t1; write " "; write_cmp c1; write " ";
17.681 - write_term t2; write " "; write_cmp c2; write " ";
17.682 - write_term t3)
17.683 - ); writeln ""; write_bounds bs)
17.684 - | write_bounds ((cplexBound (t1, c, t2)) :: bs) =
17.685 - (write_term t1; write " ";
17.686 - write_cmp c; write " ";
17.687 - write_term t2; writeln ""; write_bounds bs)
17.688 -
17.689 - val _ = write_goal goal
17.690 - val _ = (writeln ""; writeln "ST")
17.691 - val _ = write_constraints constraints
17.692 - val _ = (writeln ""; writeln "BOUNDS")
17.693 - val _ = write_bounds bounds
17.694 - val _ = (writeln ""; writeln "END")
17.695 - val _ = TextIO.closeOut f
17.696 - in
17.697 - ()
17.698 - end
17.699 -
17.700 -fun norm_Constr (constr as cplexConstr (c, (t1, t2))) =
17.701 - if not (modulo_signed is_Num t2) andalso
17.702 - modulo_signed is_Num t1
17.703 - then
17.704 - [cplexConstr (rev_cmp c, (t2, t1))]
17.705 - else if (c = cplexLe orelse c = cplexLeq) andalso
17.706 - (t1 = (cplexNeg cplexInf) orelse t2 = cplexInf)
17.707 - then
17.708 - []
17.709 - else if (c = cplexGe orelse c = cplexGeq) andalso
17.710 - (t1 = cplexInf orelse t2 = cplexNeg cplexInf)
17.711 - then
17.712 - []
17.713 - else
17.714 - [constr]
17.715 -
17.716 -fun bound2constr (cplexBounds (t1,c1,t2,c2,t3)) =
17.717 - (norm_Constr(cplexConstr (c1, (t1, t2))))
17.718 - @ (norm_Constr(cplexConstr (c2, (t2, t3))))
17.719 - | bound2constr (cplexBound (t1, cplexEq, t2)) =
17.720 - (norm_Constr(cplexConstr (cplexLeq, (t1, t2))))
17.721 - @ (norm_Constr(cplexConstr (cplexLeq, (t2, t1))))
17.722 - | bound2constr (cplexBound (t1, c1, t2)) =
17.723 - norm_Constr(cplexConstr (c1, (t1,t2)))
17.724 -
17.725 -val emptyset = Symtab.empty
17.726 -
17.727 -fun singleton v = Symtab.update (v, ()) emptyset
17.728 -
17.729 -fun merge a b = Symtab.merge (op =) (a, b)
17.730 -
17.731 -fun mergemap f ts = fold (fn x => fn table => merge table (f x)) ts Symtab.empty
17.732 -
17.733 -fun diff a b = Symtab.fold (Symtab.delete_safe o fst) b a
17.734 -
17.735 -fun collect_vars (cplexVar v) = singleton v
17.736 - | collect_vars (cplexNeg t) = collect_vars t
17.737 - | collect_vars (cplexProd (t1, t2)) =
17.738 - merge (collect_vars t1) (collect_vars t2)
17.739 - | collect_vars (cplexSum ts) = mergemap collect_vars ts
17.740 - | collect_vars _ = emptyset
17.741 -
17.742 -(* Eliminates all nonfree bounds from the linear program and produces an
17.743 - equivalent program with only free bounds
17.744 - IF for the input program P holds: is_normed_cplexProg P *)
17.745 -fun elim_nonfree_bounds (cplexProg (name, goal, constraints, bounds)) =
17.746 - let
17.747 - fun collect_constr_vars (_, cplexConstr (_, (t1,_))) =
17.748 - (collect_vars t1)
17.749 -
17.750 - val cvars = merge (collect_vars (term_of_goal goal))
17.751 - (mergemap collect_constr_vars constraints)
17.752 -
17.753 - fun collect_lower_bounded_vars
17.754 - (cplexBounds (_, _, cplexVar v, _, _)) =
17.755 - singleton v
17.756 - | collect_lower_bounded_vars
17.757 - (cplexBound (_, cplexLe, cplexVar v)) =
17.758 - singleton v
17.759 - | collect_lower_bounded_vars
17.760 - (cplexBound (_, cplexLeq, cplexVar v)) =
17.761 - singleton v
17.762 - | collect_lower_bounded_vars
17.763 - (cplexBound (cplexVar v, cplexGe,_)) =
17.764 - singleton v
17.765 - | collect_lower_bounded_vars
17.766 - (cplexBound (cplexVar v, cplexGeq, _)) =
17.767 - singleton v
17.768 - | collect_lower_bounded_vars
17.769 - (cplexBound (cplexVar v, cplexEq, _)) =
17.770 - singleton v
17.771 - | collect_lower_bounded_vars _ = emptyset
17.772 -
17.773 - val lvars = mergemap collect_lower_bounded_vars bounds
17.774 - val positive_vars = diff cvars lvars
17.775 - val zero = cplexNum "0"
17.776 -
17.777 - fun make_pos_constr v =
17.778 - (NONE, cplexConstr (cplexGeq, ((cplexVar v), zero)))
17.779 -
17.780 - fun make_free_bound v =
17.781 - cplexBounds (cplexNeg cplexInf, cplexLeq,
17.782 - cplexVar v, cplexLeq,
17.783 - cplexInf)
17.784 -
17.785 - val pos_constrs = rev (Symtab.fold
17.786 - (fn (k, _) => cons (make_pos_constr k))
17.787 - positive_vars [])
17.788 - val bound_constrs = map (pair NONE)
17.789 - (maps bound2constr bounds)
17.790 - val constraints' = constraints @ pos_constrs @ bound_constrs
17.791 - val bounds' = rev (Symtab.fold (fn (v, _) => cons (make_free_bound v)) cvars []);
17.792 - in
17.793 - cplexProg (name, goal, constraints', bounds')
17.794 - end
17.795 -
17.796 -fun relax_strict_ineqs (cplexProg (name, goals, constrs, bounds)) =
17.797 - let
17.798 - fun relax cplexLe = cplexLeq
17.799 - | relax cplexGe = cplexGeq
17.800 - | relax x = x
17.801 -
17.802 - fun relax_constr (n, cplexConstr(c, (t1, t2))) =
17.803 - (n, cplexConstr(relax c, (t1, t2)))
17.804 -
17.805 - fun relax_bounds (cplexBounds (t1, c1, t2, c2, t3)) =
17.806 - cplexBounds (t1, relax c1, t2, relax c2, t3)
17.807 - | relax_bounds (cplexBound (t1, c, t2)) =
17.808 - cplexBound (t1, relax c, t2)
17.809 - in
17.810 - cplexProg (name,
17.811 - goals,
17.812 - map relax_constr constrs,
17.813 - map relax_bounds bounds)
17.814 - end
17.815 -
17.816 -datatype cplexResult = Unbounded
17.817 - | Infeasible
17.818 - | Undefined
17.819 - | Optimal of string * ((string * string) list)
17.820 -
17.821 -fun is_separator x = forall (fn c => c = #"-") (String.explode x)
17.822 -
17.823 -fun is_sign x = (x = "+" orelse x = "-")
17.824 -
17.825 -fun is_colon x = (x = ":")
17.826 -
17.827 -fun is_resultsymbol a =
17.828 - let
17.829 - val symbol_char = String.explode "!\"#$%&()/,.;?@_`'{}|~-"
17.830 - fun is_symbol_char c = Char.isAlphaNum c orelse
17.831 - exists (fn d => d=c) symbol_char
17.832 - fun is_symbol_start c = is_symbol_char c andalso
17.833 - not (Char.isDigit c) andalso
17.834 - not (c= #".") andalso
17.835 - not (c= #"-")
17.836 - val b = String.explode a
17.837 - in
17.838 - b <> [] andalso is_symbol_start (hd b) andalso
17.839 - forall is_symbol_char b
17.840 - end
17.841 -
17.842 -val TOKEN_SIGN = 100
17.843 -val TOKEN_COLON = 101
17.844 -val TOKEN_SEPARATOR = 102
17.845 -
17.846 -fun load_glpkResult name =
17.847 - let
17.848 - val flist = [(is_NL, TOKEN_NL),
17.849 - (is_blank, TOKEN_BLANK),
17.850 - (is_num, TOKEN_NUM),
17.851 - (is_sign, TOKEN_SIGN),
17.852 - (is_colon, TOKEN_COLON),
17.853 - (is_cmp, TOKEN_CMP),
17.854 - (is_resultsymbol, TOKEN_SYMBOL),
17.855 - (is_separator, TOKEN_SEPARATOR)]
17.856 -
17.857 - val tokenize = tokenize_general flist
17.858 -
17.859 - val f = TextIO.openIn name
17.860 -
17.861 - val rest = Unsynchronized.ref []
17.862 -
17.863 - fun readToken_helper () =
17.864 - if length (!rest) > 0 then
17.865 - let val u = hd (!rest) in
17.866 - (
17.867 - rest := tl (!rest);
17.868 - SOME u
17.869 - )
17.870 - end
17.871 - else
17.872 - (case TextIO.inputLine f of
17.873 - NONE => NONE
17.874 - | SOME s => (rest := tokenize s; readToken_helper()))
17.875 -
17.876 - fun is_tt tok ty = (tok <> NONE andalso (fst (the tok)) = ty)
17.877 -
17.878 - fun pushToken a = if a = NONE then () else (rest := ((the a)::(!rest)))
17.879 -
17.880 - fun readToken () =
17.881 - let val t = readToken_helper () in
17.882 - if is_tt t TOKEN_BLANK then
17.883 - readToken ()
17.884 - else if is_tt t TOKEN_NL then
17.885 - let val t2 = readToken_helper () in
17.886 - if is_tt t2 TOKEN_SIGN then
17.887 - (pushToken (SOME (TOKEN_SEPARATOR, "-")); t)
17.888 - else
17.889 - (pushToken t2; t)
17.890 - end
17.891 - else if is_tt t TOKEN_SIGN then
17.892 - let val t2 = readToken_helper () in
17.893 - if is_tt t2 TOKEN_NUM then
17.894 - (SOME (TOKEN_NUM, (snd (the t))^(snd (the t2))))
17.895 - else
17.896 - (pushToken t2; t)
17.897 - end
17.898 - else
17.899 - t
17.900 - end
17.901 -
17.902 - fun readRestOfLine P =
17.903 - let
17.904 - val t = readToken ()
17.905 - in
17.906 - if is_tt t TOKEN_NL orelse t = NONE
17.907 - then P
17.908 - else readRestOfLine P
17.909 - end
17.910 -
17.911 - fun readHeader () =
17.912 - let
17.913 - fun readStatus () = readRestOfLine ("STATUS", snd (the (readToken ())))
17.914 - fun readObjective () = readRestOfLine ("OBJECTIVE", snd (the (readToken (); readToken (); readToken ())))
17.915 - val t1 = readToken ()
17.916 - val t2 = readToken ()
17.917 - in
17.918 - if is_tt t1 TOKEN_SYMBOL andalso is_tt t2 TOKEN_COLON
17.919 - then
17.920 - case to_upper (snd (the t1)) of
17.921 - "STATUS" => (readStatus ())::(readHeader ())
17.922 - | "OBJECTIVE" => (readObjective())::(readHeader ())
17.923 - | _ => (readRestOfLine (); readHeader ())
17.924 - else
17.925 - (pushToken t2; pushToken t1; [])
17.926 - end
17.927 -
17.928 - fun skip_until_sep () =
17.929 - let val x = readToken () in
17.930 - if is_tt x TOKEN_SEPARATOR then
17.931 - readRestOfLine ()
17.932 - else
17.933 - skip_until_sep ()
17.934 - end
17.935 -
17.936 - fun load_value () =
17.937 - let
17.938 - val t1 = readToken ()
17.939 - val t2 = readToken ()
17.940 - in
17.941 - if is_tt t1 TOKEN_NUM andalso is_tt t2 TOKEN_SYMBOL then
17.942 - let
17.943 - val t = readToken ()
17.944 - val state = if is_tt t TOKEN_NL then readToken () else t
17.945 - val _ = if is_tt state TOKEN_SYMBOL then () else raise (Load_cplexResult "state expected")
17.946 - val k = readToken ()
17.947 - in
17.948 - if is_tt k TOKEN_NUM then
17.949 - readRestOfLine (SOME (snd (the t2), snd (the k)))
17.950 - else
17.951 - raise (Load_cplexResult "number expected")
17.952 - end
17.953 - else
17.954 - (pushToken t2; pushToken t1; NONE)
17.955 - end
17.956 -
17.957 - fun load_values () =
17.958 - let val v = load_value () in
17.959 - if v = NONE then [] else (the v)::(load_values ())
17.960 - end
17.961 -
17.962 - val header = readHeader ()
17.963 -
17.964 - val result =
17.965 - case AList.lookup (op =) header "STATUS" of
17.966 - SOME "INFEASIBLE" => Infeasible
17.967 - | SOME "UNBOUNDED" => Unbounded
17.968 - | SOME "OPTIMAL" => Optimal (the (AList.lookup (op =) header "OBJECTIVE"),
17.969 - (skip_until_sep ();
17.970 - skip_until_sep ();
17.971 - load_values ()))
17.972 - | _ => Undefined
17.973 -
17.974 - val _ = TextIO.closeIn f
17.975 - in
17.976 - result
17.977 - end
17.978 - handle (Tokenize s) => raise (Load_cplexResult ("Tokenize: "^s))
17.979 - | Option => raise (Load_cplexResult "Option")
17.980 -
17.981 -fun load_cplexResult name =
17.982 - let
17.983 - val flist = [(is_NL, TOKEN_NL),
17.984 - (is_blank, TOKEN_BLANK),
17.985 - (is_num, TOKEN_NUM),
17.986 - (is_sign, TOKEN_SIGN),
17.987 - (is_colon, TOKEN_COLON),
17.988 - (is_cmp, TOKEN_CMP),
17.989 - (is_resultsymbol, TOKEN_SYMBOL)]
17.990 -
17.991 - val tokenize = tokenize_general flist
17.992 -
17.993 - val f = TextIO.openIn name
17.994 -
17.995 - val rest = Unsynchronized.ref []
17.996 -
17.997 - fun readToken_helper () =
17.998 - if length (!rest) > 0 then
17.999 - let val u = hd (!rest) in
17.1000 - (
17.1001 - rest := tl (!rest);
17.1002 - SOME u
17.1003 - )
17.1004 - end
17.1005 - else
17.1006 - (case TextIO.inputLine f of
17.1007 - NONE => NONE
17.1008 - | SOME s => (rest := tokenize s; readToken_helper()))
17.1009 -
17.1010 - fun is_tt tok ty = (tok <> NONE andalso (fst (the tok)) = ty)
17.1011 -
17.1012 - fun pushToken a = if a = NONE then () else (rest := ((the a)::(!rest)))
17.1013 -
17.1014 - fun readToken () =
17.1015 - let val t = readToken_helper () in
17.1016 - if is_tt t TOKEN_BLANK then
17.1017 - readToken ()
17.1018 - else if is_tt t TOKEN_SIGN then
17.1019 - let val t2 = readToken_helper () in
17.1020 - if is_tt t2 TOKEN_NUM then
17.1021 - (SOME (TOKEN_NUM, (snd (the t))^(snd (the t2))))
17.1022 - else
17.1023 - (pushToken t2; t)
17.1024 - end
17.1025 - else
17.1026 - t
17.1027 - end
17.1028 -
17.1029 - fun readRestOfLine P =
17.1030 - let
17.1031 - val t = readToken ()
17.1032 - in
17.1033 - if is_tt t TOKEN_NL orelse t = NONE
17.1034 - then P
17.1035 - else readRestOfLine P
17.1036 - end
17.1037 -
17.1038 - fun readHeader () =
17.1039 - let
17.1040 - fun readStatus () = readRestOfLine ("STATUS", snd (the (readToken ())))
17.1041 - fun readObjective () =
17.1042 - let
17.1043 - val t = readToken ()
17.1044 - in
17.1045 - if is_tt t TOKEN_SYMBOL andalso to_upper (snd (the t)) = "VALUE" then
17.1046 - readRestOfLine ("OBJECTIVE", snd (the (readToken())))
17.1047 - else
17.1048 - readRestOfLine ("OBJECTIVE_NAME", snd (the t))
17.1049 - end
17.1050 -
17.1051 - val t = readToken ()
17.1052 - in
17.1053 - if is_tt t TOKEN_SYMBOL then
17.1054 - case to_upper (snd (the t)) of
17.1055 - "STATUS" => (readStatus ())::(readHeader ())
17.1056 - | "OBJECTIVE" => (readObjective ())::(readHeader ())
17.1057 - | "SECTION" => (pushToken t; [])
17.1058 - | _ => (readRestOfLine (); readHeader ())
17.1059 - else
17.1060 - (readRestOfLine (); readHeader ())
17.1061 - end
17.1062 -
17.1063 - fun skip_nls () =
17.1064 - let val x = readToken () in
17.1065 - if is_tt x TOKEN_NL then
17.1066 - skip_nls ()
17.1067 - else
17.1068 - (pushToken x; ())
17.1069 - end
17.1070 -
17.1071 - fun skip_paragraph () =
17.1072 - if is_tt (readToken ()) TOKEN_NL then
17.1073 - (if is_tt (readToken ()) TOKEN_NL then
17.1074 - skip_nls ()
17.1075 - else
17.1076 - skip_paragraph ())
17.1077 - else
17.1078 - skip_paragraph ()
17.1079 -
17.1080 - fun load_value () =
17.1081 - let
17.1082 - val t1 = readToken ()
17.1083 - val t1 = if is_tt t1 TOKEN_SYMBOL andalso snd (the t1) = "A" then readToken () else t1
17.1084 - in
17.1085 - if is_tt t1 TOKEN_NUM then
17.1086 - let
17.1087 - val name = readToken ()
17.1088 - val status = readToken ()
17.1089 - val value = readToken ()
17.1090 - in
17.1091 - if is_tt name TOKEN_SYMBOL andalso
17.1092 - is_tt status TOKEN_SYMBOL andalso
17.1093 - is_tt value TOKEN_NUM
17.1094 - then
17.1095 - readRestOfLine (SOME (snd (the name), snd (the value)))
17.1096 - else
17.1097 - raise (Load_cplexResult "column line expected")
17.1098 - end
17.1099 - else
17.1100 - (pushToken t1; NONE)
17.1101 - end
17.1102 -
17.1103 - fun load_values () =
17.1104 - let val v = load_value () in
17.1105 - if v = NONE then [] else (the v)::(load_values ())
17.1106 - end
17.1107 -
17.1108 - val header = readHeader ()
17.1109 -
17.1110 - val result =
17.1111 - case AList.lookup (op =) header "STATUS" of
17.1112 - SOME "INFEASIBLE" => Infeasible
17.1113 - | SOME "NONOPTIMAL" => Unbounded
17.1114 - | SOME "OPTIMAL" => Optimal (the (AList.lookup (op =) header "OBJECTIVE"),
17.1115 - (skip_paragraph ();
17.1116 - skip_paragraph ();
17.1117 - skip_paragraph ();
17.1118 - skip_paragraph ();
17.1119 - skip_paragraph ();
17.1120 - load_values ()))
17.1121 - | _ => Undefined
17.1122 -
17.1123 - val _ = TextIO.closeIn f
17.1124 - in
17.1125 - result
17.1126 - end
17.1127 - handle (Tokenize s) => raise (Load_cplexResult ("Tokenize: "^s))
17.1128 - | Option => raise (Load_cplexResult "Option")
17.1129 -
17.1130 -exception Execute of string;
17.1131 -
17.1132 -fun tmp_file s = Path.implode (Path.expand (File.tmp_path (Path.basic s)));
17.1133 -fun wrap s = "\""^s^"\"";
17.1134 -
17.1135 -fun solve_glpk prog =
17.1136 - let
17.1137 - val name = string_of_int (Time.toMicroseconds (Time.now ()))
17.1138 - val lpname = tmp_file (name^".lp")
17.1139 - val resultname = tmp_file (name^".txt")
17.1140 - val _ = save_cplexFile lpname prog
17.1141 - val cplex_path = getenv "GLPK_PATH"
17.1142 - val cplex = if cplex_path = "" then "glpsol" else cplex_path
17.1143 - val command = (wrap cplex)^" --lpt "^(wrap lpname)^" --output "^(wrap resultname)
17.1144 - val answer = #1 (Isabelle_System.bash_output command)
17.1145 - in
17.1146 - let
17.1147 - val result = load_glpkResult resultname
17.1148 - val _ = OS.FileSys.remove lpname
17.1149 - val _ = OS.FileSys.remove resultname
17.1150 - in
17.1151 - result
17.1152 - end
17.1153 - handle (Load_cplexResult s) => raise (Execute ("Load_cplexResult: "^s^"\nExecute: "^answer))
17.1154 - | _ => raise (Execute answer) (* FIXME avoid handle _ *)
17.1155 - end
17.1156 -
17.1157 -fun solve_cplex prog =
17.1158 - let
17.1159 - fun write_script s lp r =
17.1160 - let
17.1161 - val f = TextIO.openOut s
17.1162 - val _ = TextIO.output (f, "read\n"^lp^"\noptimize\nwrite\n"^r^"\nquit")
17.1163 - val _ = TextIO.closeOut f
17.1164 - in
17.1165 - ()
17.1166 - end
17.1167 -
17.1168 - val name = string_of_int (Time.toMicroseconds (Time.now ()))
17.1169 - val lpname = tmp_file (name^".lp")
17.1170 - val resultname = tmp_file (name^".txt")
17.1171 - val scriptname = tmp_file (name^".script")
17.1172 - val _ = save_cplexFile lpname prog
17.1173 - val _ = write_script scriptname lpname resultname
17.1174 - in
17.1175 - let
17.1176 - val result = load_cplexResult resultname
17.1177 - val _ = OS.FileSys.remove lpname
17.1178 - val _ = OS.FileSys.remove resultname
17.1179 - val _ = OS.FileSys.remove scriptname
17.1180 - in
17.1181 - result
17.1182 - end
17.1183 - end
17.1184 -
17.1185 -fun solve prog =
17.1186 - case get_solver () of
17.1187 - SOLVER_DEFAULT =>
17.1188 - (case getenv "LP_SOLVER" of
17.1189 - "CPLEX" => solve_cplex prog
17.1190 - | "GLPK" => solve_glpk prog
17.1191 - | _ => raise (Execute ("LP_SOLVER must be set to CPLEX or to GLPK")))
17.1192 - | SOLVER_CPLEX => solve_cplex prog
17.1193 - | SOLVER_GLPK => solve_glpk prog
17.1194 -
17.1195 -end;
18.1 --- a/src/HOL/Matrix/FloatSparseMatrixBuilder.ML Sat Mar 17 12:26:19 2012 +0100
18.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
18.3 @@ -1,284 +0,0 @@
18.4 -(* Title: HOL/Matrix/FloatSparseMatrixBuilder.ML
18.5 - Author: Steven Obua
18.6 -*)
18.7 -
18.8 -signature FLOAT_SPARSE_MATRIX_BUILDER =
18.9 -sig
18.10 - include MATRIX_BUILDER
18.11 -
18.12 - structure cplex : CPLEX
18.13 -
18.14 - type float = Float.float
18.15 - val approx_value : int -> (float -> float) -> string -> term * term
18.16 - val approx_vector : int -> (float -> float) -> vector -> term * term
18.17 - val approx_matrix : int -> (float -> float) -> matrix -> term * term
18.18 -
18.19 - val mk_spvec_entry : int -> float -> term
18.20 - val mk_spvec_entry' : int -> term -> term
18.21 - val mk_spmat_entry : int -> term -> term
18.22 - val spvecT: typ
18.23 - val spmatT: typ
18.24 -
18.25 - val v_elem_at : vector -> int -> string option
18.26 - val m_elem_at : matrix -> int -> vector option
18.27 - val v_only_elem : vector -> int option
18.28 - val v_fold : (int * string -> 'a -> 'a) -> vector -> 'a -> 'a
18.29 - val m_fold : (int * vector -> 'a -> 'a) -> matrix -> 'a -> 'a
18.30 -
18.31 - val transpose_matrix : matrix -> matrix
18.32 -
18.33 - val cut_vector : int -> vector -> vector
18.34 - val cut_matrix : vector -> int option -> matrix -> matrix
18.35 -
18.36 - val delete_matrix : int list -> matrix -> matrix
18.37 - val cut_matrix' : int list -> matrix -> matrix
18.38 - val delete_vector : int list -> vector -> vector
18.39 - val cut_vector' : int list -> vector -> vector
18.40 -
18.41 - val indices_of_matrix : matrix -> int list
18.42 - val indices_of_vector : vector -> int list
18.43 -
18.44 - (* cplexProg c A b *)
18.45 - val cplexProg : vector -> matrix -> vector -> cplex.cplexProg * (string -> int)
18.46 - (* dual_cplexProg c A b *)
18.47 - val dual_cplexProg : vector -> matrix -> vector -> cplex.cplexProg * (string -> int)
18.48 -end;
18.49 -
18.50 -structure FloatSparseMatrixBuilder : FLOAT_SPARSE_MATRIX_BUILDER =
18.51 -struct
18.52 -
18.53 -type float = Float.float
18.54 -structure Inttab = Table(type key = int val ord = rev_order o int_ord);
18.55 -
18.56 -type vector = string Inttab.table
18.57 -type matrix = vector Inttab.table
18.58 -
18.59 -val spvec_elemT = HOLogic.mk_prodT (HOLogic.natT, HOLogic.realT);
18.60 -val spvecT = HOLogic.listT spvec_elemT;
18.61 -val spmat_elemT = HOLogic.mk_prodT (HOLogic.natT, spvecT);
18.62 -val spmatT = HOLogic.listT spmat_elemT;
18.63 -
18.64 -fun approx_value prec f =
18.65 - FloatArith.approx_float prec (fn (x, y) => (f x, f y));
18.66 -
18.67 -fun mk_spvec_entry i f =
18.68 - HOLogic.mk_prod (HOLogic.mk_number HOLogic.natT i, FloatArith.mk_float f);
18.69 -
18.70 -fun mk_spvec_entry' i x =
18.71 - HOLogic.mk_prod (HOLogic.mk_number HOLogic.natT i, x);
18.72 -
18.73 -fun mk_spmat_entry i e =
18.74 - HOLogic.mk_prod (HOLogic.mk_number HOLogic.natT i, e);
18.75 -
18.76 -fun approx_vector prec pprt vector =
18.77 - let
18.78 - fun app (index, s) (lower, upper) =
18.79 - let
18.80 - val (flower, fupper) = approx_value prec pprt s
18.81 - val index = HOLogic.mk_number HOLogic.natT index
18.82 - val elower = HOLogic.mk_prod (index, flower)
18.83 - val eupper = HOLogic.mk_prod (index, fupper)
18.84 - in (elower :: lower, eupper :: upper) end;
18.85 - in
18.86 - pairself (HOLogic.mk_list spvec_elemT) (Inttab.fold app vector ([], []))
18.87 - end;
18.88 -
18.89 -fun approx_matrix prec pprt vector =
18.90 - let
18.91 - fun app (index, v) (lower, upper) =
18.92 - let
18.93 - val (flower, fupper) = approx_vector prec pprt v
18.94 - val index = HOLogic.mk_number HOLogic.natT index
18.95 - val elower = HOLogic.mk_prod (index, flower)
18.96 - val eupper = HOLogic.mk_prod (index, fupper)
18.97 - in (elower :: lower, eupper :: upper) end;
18.98 - in
18.99 - pairself (HOLogic.mk_list spmat_elemT) (Inttab.fold app vector ([], []))
18.100 - end;
18.101 -
18.102 -exception Nat_expected of int;
18.103 -
18.104 -val zero_interval = approx_value 1 I "0"
18.105 -
18.106 -fun set_elem vector index str =
18.107 - if index < 0 then
18.108 - raise (Nat_expected index)
18.109 - else if (approx_value 1 I str) = zero_interval then
18.110 - vector
18.111 - else
18.112 - Inttab.update (index, str) vector
18.113 -
18.114 -fun set_vector matrix index vector =
18.115 - if index < 0 then
18.116 - raise (Nat_expected index)
18.117 - else if Inttab.is_empty vector then
18.118 - matrix
18.119 - else
18.120 - Inttab.update (index, vector) matrix
18.121 -
18.122 -val empty_matrix = Inttab.empty
18.123 -val empty_vector = Inttab.empty
18.124 -
18.125 -(* dual stuff *)
18.126 -
18.127 -structure cplex = Cplex
18.128 -
18.129 -fun transpose_matrix matrix =
18.130 - let
18.131 - fun upd j (i, s) =
18.132 - Inttab.map_default (i, Inttab.empty) (Inttab.update (j, s));
18.133 - fun updm (j, v) = Inttab.fold (upd j) v;
18.134 - in Inttab.fold updm matrix empty_matrix end;
18.135 -
18.136 -exception No_name of string;
18.137 -
18.138 -exception Superfluous_constr_right_hand_sides
18.139 -
18.140 -fun cplexProg c A b =
18.141 - let
18.142 - val ytable = Unsynchronized.ref Inttab.empty
18.143 - fun indexof s =
18.144 - if String.size s = 0 then raise (No_name s)
18.145 - else case Int.fromString (String.extract(s, 1, NONE)) of
18.146 - SOME i => i | NONE => raise (No_name s)
18.147 -
18.148 - fun nameof i =
18.149 - let
18.150 - val s = "x" ^ string_of_int i
18.151 - val _ = Unsynchronized.change ytable (Inttab.update (i, s))
18.152 - in
18.153 - s
18.154 - end
18.155 -
18.156 - fun split_numstr s =
18.157 - if String.isPrefix "-" s then (false,String.extract(s, 1, NONE))
18.158 - else if String.isPrefix "+" s then (true, String.extract(s, 1, NONE))
18.159 - else (true, s)
18.160 -
18.161 - fun mk_term index s =
18.162 - let
18.163 - val (p, s) = split_numstr s
18.164 - val prod = cplex.cplexProd (cplex.cplexNum s, cplex.cplexVar (nameof index))
18.165 - in
18.166 - if p then prod else cplex.cplexNeg prod
18.167 - end
18.168 -
18.169 - fun vec2sum vector =
18.170 - cplex.cplexSum (Inttab.fold (fn (index, s) => fn list => (mk_term index s) :: list) vector [])
18.171 -
18.172 - fun mk_constr index vector c =
18.173 - let
18.174 - val s = case Inttab.lookup c index of SOME s => s | NONE => "0"
18.175 - val (p, s) = split_numstr s
18.176 - val num = if p then cplex.cplexNum s else cplex.cplexNeg (cplex.cplexNum s)
18.177 - in
18.178 - (NONE, cplex.cplexConstr (cplex.cplexLeq, (vec2sum vector, num)))
18.179 - end
18.180 -
18.181 - fun delete index c = Inttab.delete index c handle Inttab.UNDEF _ => c
18.182 -
18.183 - val (list, b) = Inttab.fold
18.184 - (fn (index, v) => fn (list, c) => ((mk_constr index v c)::list, delete index c))
18.185 - A ([], b)
18.186 - val _ = if Inttab.is_empty b then () else raise Superfluous_constr_right_hand_sides
18.187 -
18.188 - fun mk_free y = cplex.cplexBounds (cplex.cplexNeg cplex.cplexInf, cplex.cplexLeq,
18.189 - cplex.cplexVar y, cplex.cplexLeq,
18.190 - cplex.cplexInf)
18.191 -
18.192 - val yvars = Inttab.fold (fn (_, y) => fn l => (mk_free y)::l) (!ytable) []
18.193 -
18.194 - val prog = cplex.cplexProg ("original", cplex.cplexMaximize (vec2sum c), list, yvars)
18.195 - in
18.196 - (prog, indexof)
18.197 - end
18.198 -
18.199 -
18.200 -fun dual_cplexProg c A b =
18.201 - let
18.202 - fun indexof s =
18.203 - if String.size s = 0 then raise (No_name s)
18.204 - else case Int.fromString (String.extract(s, 1, NONE)) of
18.205 - SOME i => i | NONE => raise (No_name s)
18.206 -
18.207 - fun nameof i = "y" ^ string_of_int i
18.208 -
18.209 - fun split_numstr s =
18.210 - if String.isPrefix "-" s then (false,String.extract(s, 1, NONE))
18.211 - else if String.isPrefix "+" s then (true, String.extract(s, 1, NONE))
18.212 - else (true, s)
18.213 -
18.214 - fun mk_term index s =
18.215 - let
18.216 - val (p, s) = split_numstr s
18.217 - val prod = cplex.cplexProd (cplex.cplexNum s, cplex.cplexVar (nameof index))
18.218 - in
18.219 - if p then prod else cplex.cplexNeg prod
18.220 - end
18.221 -
18.222 - fun vec2sum vector =
18.223 - cplex.cplexSum (Inttab.fold (fn (index, s) => fn list => (mk_term index s)::list) vector [])
18.224 -
18.225 - fun mk_constr index vector c =
18.226 - let
18.227 - val s = case Inttab.lookup c index of SOME s => s | NONE => "0"
18.228 - val (p, s) = split_numstr s
18.229 - val num = if p then cplex.cplexNum s else cplex.cplexNeg (cplex.cplexNum s)
18.230 - in
18.231 - (NONE, cplex.cplexConstr (cplex.cplexEq, (vec2sum vector, num)))
18.232 - end
18.233 -
18.234 - fun delete index c = Inttab.delete index c handle Inttab.UNDEF _ => c
18.235 -
18.236 - val (list, c) = Inttab.fold
18.237 - (fn (index, v) => fn (list, c) => ((mk_constr index v c)::list, delete index c))
18.238 - (transpose_matrix A) ([], c)
18.239 - val _ = if Inttab.is_empty c then () else raise Superfluous_constr_right_hand_sides
18.240 -
18.241 - val prog = cplex.cplexProg ("dual", cplex.cplexMinimize (vec2sum b), list, [])
18.242 - in
18.243 - (prog, indexof)
18.244 - end
18.245 -
18.246 -fun cut_vector size v =
18.247 - let
18.248 - val count = Unsynchronized.ref 0;
18.249 - fun app (i, s) = if (!count < size) then
18.250 - (count := !count +1 ; Inttab.update (i, s))
18.251 - else I
18.252 - in
18.253 - Inttab.fold app v empty_vector
18.254 - end
18.255 -
18.256 -fun cut_matrix vfilter vsize m =
18.257 - let
18.258 - fun app (i, v) =
18.259 - if is_none (Inttab.lookup vfilter i) then I
18.260 - else case vsize
18.261 - of NONE => Inttab.update (i, v)
18.262 - | SOME s => Inttab.update (i, cut_vector s v)
18.263 - in Inttab.fold app m empty_matrix end
18.264 -
18.265 -fun v_elem_at v i = Inttab.lookup v i
18.266 -fun m_elem_at m i = Inttab.lookup m i
18.267 -
18.268 -fun v_only_elem v =
18.269 - case Inttab.min_key v of
18.270 - NONE => NONE
18.271 - | SOME vmin => (case Inttab.max_key v of
18.272 - NONE => SOME vmin
18.273 - | SOME vmax => if vmin = vmax then SOME vmin else NONE)
18.274 -
18.275 -fun v_fold f = Inttab.fold f;
18.276 -fun m_fold f = Inttab.fold f;
18.277 -
18.278 -fun indices_of_vector v = Inttab.keys v
18.279 -fun indices_of_matrix m = Inttab.keys m
18.280 -fun delete_vector indices v = fold Inttab.delete indices v
18.281 -fun delete_matrix indices m = fold Inttab.delete indices m
18.282 -fun cut_matrix' indices _ = fold (fn i => fn m => (case Inttab.lookup m i of NONE => m | SOME v => Inttab.update (i, v) m)) indices Inttab.empty
18.283 -fun cut_vector' indices _ = fold (fn i => fn v => (case Inttab.lookup v i of NONE => v | SOME x => Inttab.update (i, x) v)) indices Inttab.empty
18.284 -
18.285 -
18.286 -
18.287 -end;
19.1 --- a/src/HOL/Matrix/LP.thy Sat Mar 17 12:26:19 2012 +0100
19.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
19.3 @@ -1,164 +0,0 @@
19.4 -(* Title: HOL/Matrix/LP.thy
19.5 - Author: Steven Obua
19.6 -*)
19.7 -
19.8 -theory LP
19.9 -imports Main "~~/src/HOL/Library/Lattice_Algebras"
19.10 -begin
19.11 -
19.12 -lemma le_add_right_mono:
19.13 - assumes
19.14 - "a <= b + (c::'a::ordered_ab_group_add)"
19.15 - "c <= d"
19.16 - shows "a <= b + d"
19.17 - apply (rule_tac order_trans[where y = "b+c"])
19.18 - apply (simp_all add: assms)
19.19 - done
19.20 -
19.21 -lemma linprog_dual_estimate:
19.22 - assumes
19.23 - "A * x \<le> (b::'a::lattice_ring)"
19.24 - "0 \<le> y"
19.25 - "abs (A - A') \<le> \<delta>A"
19.26 - "b \<le> b'"
19.27 - "abs (c - c') \<le> \<delta>c"
19.28 - "abs x \<le> r"
19.29 - shows
19.30 - "c * x \<le> y * b' + (y * \<delta>A + abs (y * A' - c') + \<delta>c) * r"
19.31 -proof -
19.32 - from assms have 1: "y * b <= y * b'" by (simp add: mult_left_mono)
19.33 - from assms have 2: "y * (A * x) <= y * b" by (simp add: mult_left_mono)
19.34 - have 3: "y * (A * x) = c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x" by (simp add: algebra_simps)
19.35 - from 1 2 3 have 4: "c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x <= y * b'" by simp
19.36 - have 5: "c * x <= y * b' + abs((y * (A - A') + (y * A' - c') + (c'-c)) * x)"
19.37 - by (simp only: 4 estimate_by_abs)
19.38 - have 6: "abs((y * (A - A') + (y * A' - c') + (c'-c)) * x) <= abs (y * (A - A') + (y * A' - c') + (c'-c)) * abs x"
19.39 - by (simp add: abs_le_mult)
19.40 - have 7: "(abs (y * (A - A') + (y * A' - c') + (c'-c))) * abs x <= (abs (y * (A-A') + (y*A'-c')) + abs(c'-c)) * abs x"
19.41 - by(rule abs_triangle_ineq [THEN mult_right_mono]) simp
19.42 - have 8: " (abs (y * (A-A') + (y*A'-c')) + abs(c'-c)) * abs x <= (abs (y * (A-A')) + abs (y*A'-c') + abs(c'-c)) * abs x"
19.43 - by (simp add: abs_triangle_ineq mult_right_mono)
19.44 - have 9: "(abs (y * (A-A')) + abs (y*A'-c') + abs(c'-c)) * abs x <= (abs y * abs (A-A') + abs (y*A'-c') + abs (c'-c)) * abs x"
19.45 - by (simp add: abs_le_mult mult_right_mono)
19.46 - have 10: "c'-c = -(c-c')" by (simp add: algebra_simps)
19.47 - have 11: "abs (c'-c) = abs (c-c')"
19.48 - by (subst 10, subst abs_minus_cancel, simp)
19.49 - have 12: "(abs y * abs (A-A') + abs (y*A'-c') + abs (c'-c)) * abs x <= (abs y * abs (A-A') + abs (y*A'-c') + \<delta>c) * abs x"
19.50 - by (simp add: 11 assms mult_right_mono)
19.51 - have 13: "(abs y * abs (A-A') + abs (y*A'-c') + \<delta>c) * abs x <= (abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * abs x"
19.52 - by (simp add: assms mult_right_mono mult_left_mono)
19.53 - have r: "(abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * abs x <= (abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * r"
19.54 - apply (rule mult_left_mono)
19.55 - apply (simp add: assms)
19.56 - apply (rule_tac add_mono[of "0::'a" _ "0", simplified])+
19.57 - apply (rule mult_left_mono[of "0" "\<delta>A", simplified])
19.58 - apply (simp_all)
19.59 - apply (rule order_trans[where y="abs (A-A')"], simp_all add: assms)
19.60 - apply (rule order_trans[where y="abs (c-c')"], simp_all add: assms)
19.61 - done
19.62 - from 6 7 8 9 12 13 r have 14:" abs((y * (A - A') + (y * A' - c') + (c'-c)) * x) <=(abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * r"
19.63 - by (simp)
19.64 - show ?thesis
19.65 - apply (rule le_add_right_mono[of _ _ "abs((y * (A - A') + (y * A' - c') + (c'-c)) * x)"])
19.66 - apply (simp_all only: 5 14[simplified abs_of_nonneg[of y, simplified assms]])
19.67 - done
19.68 -qed
19.69 -
19.70 -lemma le_ge_imp_abs_diff_1:
19.71 - assumes
19.72 - "A1 <= (A::'a::lattice_ring)"
19.73 - "A <= A2"
19.74 - shows "abs (A-A1) <= A2-A1"
19.75 -proof -
19.76 - have "0 <= A - A1"
19.77 - proof -
19.78 - have 1: "A - A1 = A + (- A1)" by simp
19.79 - show ?thesis by (simp only: 1 add_right_mono[of A1 A "-A1", simplified, simplified assms])
19.80 - qed
19.81 - then have "abs (A-A1) = A-A1" by (rule abs_of_nonneg)
19.82 - with assms show "abs (A-A1) <= (A2-A1)" by simp
19.83 -qed
19.84 -
19.85 -lemma mult_le_prts:
19.86 - assumes
19.87 - "a1 <= (a::'a::lattice_ring)"
19.88 - "a <= a2"
19.89 - "b1 <= b"
19.90 - "b <= b2"
19.91 - shows
19.92 - "a * b <= pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
19.93 -proof -
19.94 - have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
19.95 - apply (subst prts[symmetric])+
19.96 - apply simp
19.97 - done
19.98 - then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
19.99 - by (simp add: algebra_simps)
19.100 - moreover have "pprt a * pprt b <= pprt a2 * pprt b2"
19.101 - by (simp_all add: assms mult_mono)
19.102 - moreover have "pprt a * nprt b <= pprt a1 * nprt b2"
19.103 - proof -
19.104 - have "pprt a * nprt b <= pprt a * nprt b2"
19.105 - by (simp add: mult_left_mono assms)
19.106 - moreover have "pprt a * nprt b2 <= pprt a1 * nprt b2"
19.107 - by (simp add: mult_right_mono_neg assms)
19.108 - ultimately show ?thesis
19.109 - by simp
19.110 - qed
19.111 - moreover have "nprt a * pprt b <= nprt a2 * pprt b1"
19.112 - proof -
19.113 - have "nprt a * pprt b <= nprt a2 * pprt b"
19.114 - by (simp add: mult_right_mono assms)
19.115 - moreover have "nprt a2 * pprt b <= nprt a2 * pprt b1"
19.116 - by (simp add: mult_left_mono_neg assms)
19.117 - ultimately show ?thesis
19.118 - by simp
19.119 - qed
19.120 - moreover have "nprt a * nprt b <= nprt a1 * nprt b1"
19.121 - proof -
19.122 - have "nprt a * nprt b <= nprt a * nprt b1"
19.123 - by (simp add: mult_left_mono_neg assms)
19.124 - moreover have "nprt a * nprt b1 <= nprt a1 * nprt b1"
19.125 - by (simp add: mult_right_mono_neg assms)
19.126 - ultimately show ?thesis
19.127 - by simp
19.128 - qed
19.129 - ultimately show ?thesis
19.130 - by - (rule add_mono | simp)+
19.131 -qed
19.132 -
19.133 -lemma mult_le_dual_prts:
19.134 - assumes
19.135 - "A * x \<le> (b::'a::lattice_ring)"
19.136 - "0 \<le> y"
19.137 - "A1 \<le> A"
19.138 - "A \<le> A2"
19.139 - "c1 \<le> c"
19.140 - "c \<le> c2"
19.141 - "r1 \<le> x"
19.142 - "x \<le> r2"
19.143 - shows
19.144 - "c * x \<le> y * b + (let s1 = c1 - y * A2; s2 = c2 - y * A1 in pprt s2 * pprt r2 + pprt s1 * nprt r2 + nprt s2 * pprt r1 + nprt s1 * nprt r1)"
19.145 - (is "_ <= _ + ?C")
19.146 -proof -
19.147 - from assms have "y * (A * x) <= y * b" by (simp add: mult_left_mono)
19.148 - moreover have "y * (A * x) = c * x + (y * A - c) * x" by (simp add: algebra_simps)
19.149 - ultimately have "c * x + (y * A - c) * x <= y * b" by simp
19.150 - then have "c * x <= y * b - (y * A - c) * x" by (simp add: le_diff_eq)
19.151 - then have cx: "c * x <= y * b + (c - y * A) * x" by (simp add: algebra_simps)
19.152 - have s2: "c - y * A <= c2 - y * A1"
19.153 - by (simp add: diff_minus assms add_mono mult_left_mono)
19.154 - have s1: "c1 - y * A2 <= c - y * A"
19.155 - by (simp add: diff_minus assms add_mono mult_left_mono)
19.156 - have prts: "(c - y * A) * x <= ?C"
19.157 - apply (simp add: Let_def)
19.158 - apply (rule mult_le_prts)
19.159 - apply (simp_all add: assms s1 s2)
19.160 - done
19.161 - then have "y * b + (c - y * A) * x <= y * b + ?C"
19.162 - by simp
19.163 - with cx show ?thesis
19.164 - by(simp only:)
19.165 -qed
19.166 -
19.167 -end
19.168 \ No newline at end of file
20.1 --- a/src/HOL/Matrix/Matrix.thy Sat Mar 17 12:26:19 2012 +0100
20.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
20.3 @@ -1,1836 +0,0 @@
20.4 -(* Title: HOL/Matrix/Matrix.thy
20.5 - Author: Steven Obua
20.6 -*)
20.7 -
20.8 -theory Matrix
20.9 -imports Main "~~/src/HOL/Library/Lattice_Algebras"
20.10 -begin
20.11 -
20.12 -type_synonym 'a infmatrix = "nat \<Rightarrow> nat \<Rightarrow> 'a"
20.13 -
20.14 -definition nonzero_positions :: "(nat \<Rightarrow> nat \<Rightarrow> 'a::zero) \<Rightarrow> (nat \<times> nat) set" where
20.15 - "nonzero_positions A = {pos. A (fst pos) (snd pos) ~= 0}"
20.16 -
20.17 -definition "matrix = {(f::(nat \<Rightarrow> nat \<Rightarrow> 'a::zero)). finite (nonzero_positions f)}"
20.18 -
20.19 -typedef (open) 'a matrix = "matrix :: (nat \<Rightarrow> nat \<Rightarrow> 'a::zero) set"
20.20 - unfolding matrix_def
20.21 -proof
20.22 - show "(\<lambda>j i. 0) \<in> {(f::(nat \<Rightarrow> nat \<Rightarrow> 'a::zero)). finite (nonzero_positions f)}"
20.23 - by (simp add: nonzero_positions_def)
20.24 -qed
20.25 -
20.26 -declare Rep_matrix_inverse[simp]
20.27 -
20.28 -lemma finite_nonzero_positions : "finite (nonzero_positions (Rep_matrix A))"
20.29 - by (induct A) (simp add: Abs_matrix_inverse matrix_def)
20.30 -
20.31 -definition nrows :: "('a::zero) matrix \<Rightarrow> nat" where
20.32 - "nrows A == if nonzero_positions(Rep_matrix A) = {} then 0 else Suc(Max ((image fst) (nonzero_positions (Rep_matrix A))))"
20.33 -
20.34 -definition ncols :: "('a::zero) matrix \<Rightarrow> nat" where
20.35 - "ncols A == if nonzero_positions(Rep_matrix A) = {} then 0 else Suc(Max ((image snd) (nonzero_positions (Rep_matrix A))))"
20.36 -
20.37 -lemma nrows:
20.38 - assumes hyp: "nrows A \<le> m"
20.39 - shows "(Rep_matrix A m n) = 0"
20.40 -proof cases
20.41 - assume "nonzero_positions(Rep_matrix A) = {}"
20.42 - then show "(Rep_matrix A m n) = 0" by (simp add: nonzero_positions_def)
20.43 -next
20.44 - assume a: "nonzero_positions(Rep_matrix A) \<noteq> {}"
20.45 - let ?S = "fst`(nonzero_positions(Rep_matrix A))"
20.46 - have c: "finite (?S)" by (simp add: finite_nonzero_positions)
20.47 - from hyp have d: "Max (?S) < m" by (simp add: a nrows_def)
20.48 - have "m \<notin> ?S"
20.49 - proof -
20.50 - have "m \<in> ?S \<Longrightarrow> m <= Max(?S)" by (simp add: Max_ge [OF c])
20.51 - moreover from d have "~(m <= Max ?S)" by (simp)
20.52 - ultimately show "m \<notin> ?S" by (auto)
20.53 - qed
20.54 - thus "Rep_matrix A m n = 0" by (simp add: nonzero_positions_def image_Collect)
20.55 -qed
20.56 -
20.57 -definition transpose_infmatrix :: "'a infmatrix \<Rightarrow> 'a infmatrix" where
20.58 - "transpose_infmatrix A j i == A i j"
20.59 -
20.60 -definition transpose_matrix :: "('a::zero) matrix \<Rightarrow> 'a matrix" where
20.61 - "transpose_matrix == Abs_matrix o transpose_infmatrix o Rep_matrix"
20.62 -
20.63 -declare transpose_infmatrix_def[simp]
20.64 -
20.65 -lemma transpose_infmatrix_twice[simp]: "transpose_infmatrix (transpose_infmatrix A) = A"
20.66 -by ((rule ext)+, simp)
20.67 -
20.68 -lemma transpose_infmatrix: "transpose_infmatrix (% j i. P j i) = (% j i. P i j)"
20.69 - apply (rule ext)+
20.70 - by simp
20.71 -
20.72 -lemma transpose_infmatrix_closed[simp]: "Rep_matrix (Abs_matrix (transpose_infmatrix (Rep_matrix x))) = transpose_infmatrix (Rep_matrix x)"
20.73 -apply (rule Abs_matrix_inverse)
20.74 -apply (simp add: matrix_def nonzero_positions_def image_def)
20.75 -proof -
20.76 - let ?A = "{pos. Rep_matrix x (snd pos) (fst pos) \<noteq> 0}"
20.77 - let ?swap = "% pos. (snd pos, fst pos)"
20.78 - let ?B = "{pos. Rep_matrix x (fst pos) (snd pos) \<noteq> 0}"
20.79 - have swap_image: "?swap`?A = ?B"
20.80 - apply (simp add: image_def)
20.81 - apply (rule set_eqI)
20.82 - apply (simp)
20.83 - proof
20.84 - fix y
20.85 - assume hyp: "\<exists>a b. Rep_matrix x b a \<noteq> 0 \<and> y = (b, a)"
20.86 - thus "Rep_matrix x (fst y) (snd y) \<noteq> 0"
20.87 - proof -
20.88 - from hyp obtain a b where "(Rep_matrix x b a \<noteq> 0 & y = (b,a))" by blast
20.89 - then show "Rep_matrix x (fst y) (snd y) \<noteq> 0" by (simp)
20.90 - qed
20.91 - next
20.92 - fix y
20.93 - assume hyp: "Rep_matrix x (fst y) (snd y) \<noteq> 0"
20.94 - show "\<exists> a b. (Rep_matrix x b a \<noteq> 0 & y = (b,a))"
20.95 - by (rule exI[of _ "snd y"], rule exI[of _ "fst y"]) (simp add: hyp)
20.96 - qed
20.97 - then have "finite (?swap`?A)"
20.98 - proof -
20.99 - have "finite (nonzero_positions (Rep_matrix x))" by (simp add: finite_nonzero_positions)
20.100 - then have "finite ?B" by (simp add: nonzero_positions_def)
20.101 - with swap_image show "finite (?swap`?A)" by (simp)
20.102 - qed
20.103 - moreover
20.104 - have "inj_on ?swap ?A" by (simp add: inj_on_def)
20.105 - ultimately show "finite ?A"by (rule finite_imageD[of ?swap ?A])
20.106 -qed
20.107 -
20.108 -lemma infmatrixforward: "(x::'a infmatrix) = y \<Longrightarrow> \<forall> a b. x a b = y a b" by auto
20.109 -
20.110 -lemma transpose_infmatrix_inject: "(transpose_infmatrix A = transpose_infmatrix B) = (A = B)"
20.111 -apply (auto)
20.112 -apply (rule ext)+
20.113 -apply (simp add: transpose_infmatrix)
20.114 -apply (drule infmatrixforward)
20.115 -apply (simp)
20.116 -done
20.117 -
20.118 -lemma transpose_matrix_inject: "(transpose_matrix A = transpose_matrix B) = (A = B)"
20.119 -apply (simp add: transpose_matrix_def)
20.120 -apply (subst Rep_matrix_inject[THEN sym])+
20.121 -apply (simp only: transpose_infmatrix_closed transpose_infmatrix_inject)
20.122 -done
20.123 -
20.124 -lemma transpose_matrix[simp]: "Rep_matrix(transpose_matrix A) j i = Rep_matrix A i j"
20.125 -by (simp add: transpose_matrix_def)
20.126 -
20.127 -lemma transpose_transpose_id[simp]: "transpose_matrix (transpose_matrix A) = A"
20.128 -by (simp add: transpose_matrix_def)
20.129 -
20.130 -lemma nrows_transpose[simp]: "nrows (transpose_matrix A) = ncols A"
20.131 -by (simp add: nrows_def ncols_def nonzero_positions_def transpose_matrix_def image_def)
20.132 -
20.133 -lemma ncols_transpose[simp]: "ncols (transpose_matrix A) = nrows A"
20.134 -by (simp add: nrows_def ncols_def nonzero_positions_def transpose_matrix_def image_def)
20.135 -
20.136 -lemma ncols: "ncols A <= n \<Longrightarrow> Rep_matrix A m n = 0"
20.137 -proof -
20.138 - assume "ncols A <= n"
20.139 - then have "nrows (transpose_matrix A) <= n" by (simp)
20.140 - then have "Rep_matrix (transpose_matrix A) n m = 0" by (rule nrows)
20.141 - thus "Rep_matrix A m n = 0" by (simp add: transpose_matrix_def)
20.142 -qed
20.143 -
20.144 -lemma ncols_le: "(ncols A <= n) = (! j i. n <= i \<longrightarrow> (Rep_matrix A j i) = 0)" (is "_ = ?st")
20.145 -apply (auto)
20.146 -apply (simp add: ncols)
20.147 -proof (simp add: ncols_def, auto)
20.148 - let ?P = "nonzero_positions (Rep_matrix A)"
20.149 - let ?p = "snd`?P"
20.150 - have a:"finite ?p" by (simp add: finite_nonzero_positions)
20.151 - let ?m = "Max ?p"
20.152 - assume "~(Suc (?m) <= n)"
20.153 - then have b:"n <= ?m" by (simp)
20.154 - fix a b
20.155 - assume "(a,b) \<in> ?P"
20.156 - then have "?p \<noteq> {}" by (auto)
20.157 - with a have "?m \<in> ?p" by (simp)
20.158 - moreover have "!x. (x \<in> ?p \<longrightarrow> (? y. (Rep_matrix A y x) \<noteq> 0))" by (simp add: nonzero_positions_def image_def)
20.159 - ultimately have "? y. (Rep_matrix A y ?m) \<noteq> 0" by (simp)
20.160 - moreover assume ?st
20.161 - ultimately show "False" using b by (simp)
20.162 -qed
20.163 -
20.164 -lemma less_ncols: "(n < ncols A) = (? j i. n <= i & (Rep_matrix A j i) \<noteq> 0)"
20.165 -proof -
20.166 - have a: "!! (a::nat) b. (a < b) = (~(b <= a))" by arith
20.167 - show ?thesis by (simp add: a ncols_le)
20.168 -qed
20.169 -
20.170 -lemma le_ncols: "(n <= ncols A) = (\<forall> m. (\<forall> j i. m <= i \<longrightarrow> (Rep_matrix A j i) = 0) \<longrightarrow> n <= m)"
20.171 -apply (auto)
20.172 -apply (subgoal_tac "ncols A <= m")
20.173 -apply (simp)
20.174 -apply (simp add: ncols_le)
20.175 -apply (drule_tac x="ncols A" in spec)
20.176 -by (simp add: ncols)
20.177 -
20.178 -lemma nrows_le: "(nrows A <= n) = (! j i. n <= j \<longrightarrow> (Rep_matrix A j i) = 0)" (is ?s)
20.179 -proof -
20.180 - have "(nrows A <= n) = (ncols (transpose_matrix A) <= n)" by (simp)
20.181 - also have "\<dots> = (! j i. n <= i \<longrightarrow> (Rep_matrix (transpose_matrix A) j i = 0))" by (rule ncols_le)
20.182 - also have "\<dots> = (! j i. n <= i \<longrightarrow> (Rep_matrix A i j) = 0)" by (simp)
20.183 - finally show "(nrows A <= n) = (! j i. n <= j \<longrightarrow> (Rep_matrix A j i) = 0)" by (auto)
20.184 -qed
20.185 -
20.186 -lemma less_nrows: "(m < nrows A) = (? j i. m <= j & (Rep_matrix A j i) \<noteq> 0)"
20.187 -proof -
20.188 - have a: "!! (a::nat) b. (a < b) = (~(b <= a))" by arith
20.189 - show ?thesis by (simp add: a nrows_le)
20.190 -qed
20.191 -
20.192 -lemma le_nrows: "(n <= nrows A) = (\<forall> m. (\<forall> j i. m <= j \<longrightarrow> (Rep_matrix A j i) = 0) \<longrightarrow> n <= m)"
20.193 -apply (auto)
20.194 -apply (subgoal_tac "nrows A <= m")
20.195 -apply (simp)
20.196 -apply (simp add: nrows_le)
20.197 -apply (drule_tac x="nrows A" in spec)
20.198 -by (simp add: nrows)
20.199 -
20.200 -lemma nrows_notzero: "Rep_matrix A m n \<noteq> 0 \<Longrightarrow> m < nrows A"
20.201 -apply (case_tac "nrows A <= m")
20.202 -apply (simp_all add: nrows)
20.203 -done
20.204 -
20.205 -lemma ncols_notzero: "Rep_matrix A m n \<noteq> 0 \<Longrightarrow> n < ncols A"
20.206 -apply (case_tac "ncols A <= n")
20.207 -apply (simp_all add: ncols)
20.208 -done
20.209 -
20.210 -lemma finite_natarray1: "finite {x. x < (n::nat)}"
20.211 -apply (induct n)
20.212 -apply (simp)
20.213 -proof -
20.214 - fix n
20.215 - have "{x. x < Suc n} = insert n {x. x < n}" by (rule set_eqI, simp, arith)
20.216 - moreover assume "finite {x. x < n}"
20.217 - ultimately show "finite {x. x < Suc n}" by (simp)
20.218 -qed
20.219 -
20.220 -lemma finite_natarray2: "finite {pos. (fst pos) < (m::nat) & (snd pos) < (n::nat)}"
20.221 - apply (induct m)
20.222 - apply (simp+)
20.223 - proof -
20.224 - fix m::nat
20.225 - let ?s0 = "{pos. fst pos < m & snd pos < n}"
20.226 - let ?s1 = "{pos. fst pos < (Suc m) & snd pos < n}"
20.227 - let ?sd = "{pos. fst pos = m & snd pos < n}"
20.228 - assume f0: "finite ?s0"
20.229 - have f1: "finite ?sd"
20.230 - proof -
20.231 - let ?f = "% x. (m, x)"
20.232 - have "{pos. fst pos = m & snd pos < n} = ?f ` {x. x < n}" by (rule set_eqI, simp add: image_def, auto)
20.233 - moreover have "finite {x. x < n}" by (simp add: finite_natarray1)
20.234 - ultimately show "finite {pos. fst pos = m & snd pos < n}" by (simp)
20.235 - qed
20.236 - have su: "?s0 \<union> ?sd = ?s1" by (rule set_eqI, simp, arith)
20.237 - from f0 f1 have "finite (?s0 \<union> ?sd)" by (rule finite_UnI)
20.238 - with su show "finite ?s1" by (simp)
20.239 -qed
20.240 -
20.241 -lemma RepAbs_matrix:
20.242 - assumes aem: "? m. ! j i. m <= j \<longrightarrow> x j i = 0" (is ?em) and aen:"? n. ! j i. (n <= i \<longrightarrow> x j i = 0)" (is ?en)
20.243 - shows "(Rep_matrix (Abs_matrix x)) = x"
20.244 -apply (rule Abs_matrix_inverse)
20.245 -apply (simp add: matrix_def nonzero_positions_def)
20.246 -proof -
20.247 - from aem obtain m where a: "! j i. m <= j \<longrightarrow> x j i = 0" by (blast)
20.248 - from aen obtain n where b: "! j i. n <= i \<longrightarrow> x j i = 0" by (blast)
20.249 - let ?u = "{pos. x (fst pos) (snd pos) \<noteq> 0}"
20.250 - let ?v = "{pos. fst pos < m & snd pos < n}"
20.251 - have c: "!! (m::nat) a. ~(m <= a) \<Longrightarrow> a < m" by (arith)
20.252 - from a b have "(?u \<inter> (-?v)) = {}"
20.253 - apply (simp)
20.254 - apply (rule set_eqI)
20.255 - apply (simp)
20.256 - apply auto
20.257 - by (rule c, auto)+
20.258 - then have d: "?u \<subseteq> ?v" by blast
20.259 - moreover have "finite ?v" by (simp add: finite_natarray2)
20.260 - ultimately show "finite ?u" by (rule finite_subset)
20.261 -qed
20.262 -
20.263 -definition apply_infmatrix :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a infmatrix \<Rightarrow> 'b infmatrix" where
20.264 - "apply_infmatrix f == % A. (% j i. f (A j i))"
20.265 -
20.266 -definition apply_matrix :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a::zero) matrix \<Rightarrow> ('b::zero) matrix" where
20.267 - "apply_matrix f == % A. Abs_matrix (apply_infmatrix f (Rep_matrix A))"
20.268 -
20.269 -definition combine_infmatrix :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a infmatrix \<Rightarrow> 'b infmatrix \<Rightarrow> 'c infmatrix" where
20.270 - "combine_infmatrix f == % A B. (% j i. f (A j i) (B j i))"
20.271 -
20.272 -definition combine_matrix :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a::zero) matrix \<Rightarrow> ('b::zero) matrix \<Rightarrow> ('c::zero) matrix" where
20.273 - "combine_matrix f == % A B. Abs_matrix (combine_infmatrix f (Rep_matrix A) (Rep_matrix B))"
20.274 -
20.275 -lemma expand_apply_infmatrix[simp]: "apply_infmatrix f A j i = f (A j i)"
20.276 -by (simp add: apply_infmatrix_def)
20.277 -
20.278 -lemma expand_combine_infmatrix[simp]: "combine_infmatrix f A B j i = f (A j i) (B j i)"
20.279 -by (simp add: combine_infmatrix_def)
20.280 -
20.281 -definition commutative :: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool" where
20.282 -"commutative f == ! x y. f x y = f y x"
20.283 -
20.284 -definition associative :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
20.285 -"associative f == ! x y z. f (f x y) z = f x (f y z)"
20.286 -
20.287 -text{*
20.288 -To reason about associativity and commutativity of operations on matrices,
20.289 -let's take a step back and look at the general situtation: Assume that we have
20.290 -sets $A$ and $B$ with $B \subset A$ and an abstraction $u: A \rightarrow B$. This abstraction has to fulfill $u(b) = b$ for all $b \in B$, but is arbitrary otherwise.
20.291 -Each function $f: A \times A \rightarrow A$ now induces a function $f': B \times B \rightarrow B$ by $f' = u \circ f$.
20.292 -It is obvious that commutativity of $f$ implies commutativity of $f'$: $f' x y = u (f x y) = u (f y x) = f' y x.$
20.293 -*}
20.294 -
20.295 -lemma combine_infmatrix_commute:
20.296 - "commutative f \<Longrightarrow> commutative (combine_infmatrix f)"
20.297 -by (simp add: commutative_def combine_infmatrix_def)
20.298 -
20.299 -lemma combine_matrix_commute:
20.300 -"commutative f \<Longrightarrow> commutative (combine_matrix f)"
20.301 -by (simp add: combine_matrix_def commutative_def combine_infmatrix_def)
20.302 -
20.303 -text{*
20.304 -On the contrary, given an associative function $f$ we cannot expect $f'$ to be associative. A counterexample is given by $A=\ganz$, $B=\{-1, 0, 1\}$,
20.305 -as $f$ we take addition on $\ganz$, which is clearly associative. The abstraction is given by $u(a) = 0$ for $a \notin B$. Then we have
20.306 -\[ f' (f' 1 1) -1 = u(f (u (f 1 1)) -1) = u(f (u 2) -1) = u (f 0 -1) = -1, \]
20.307 -but on the other hand we have
20.308 -\[ f' 1 (f' 1 -1) = u (f 1 (u (f 1 -1))) = u (f 1 0) = 1.\]
20.309 -A way out of this problem is to assume that $f(A\times A)\subset A$ holds, and this is what we are going to do:
20.310 -*}
20.311 -
20.312 -lemma nonzero_positions_combine_infmatrix[simp]: "f 0 0 = 0 \<Longrightarrow> nonzero_positions (combine_infmatrix f A B) \<subseteq> (nonzero_positions A) \<union> (nonzero_positions B)"
20.313 -by (rule subsetI, simp add: nonzero_positions_def combine_infmatrix_def, auto)
20.314 -
20.315 -lemma finite_nonzero_positions_Rep[simp]: "finite (nonzero_positions (Rep_matrix A))"
20.316 -by (insert Rep_matrix [of A], simp add: matrix_def)
20.317 -
20.318 -lemma combine_infmatrix_closed [simp]:
20.319 - "f 0 0 = 0 \<Longrightarrow> Rep_matrix (Abs_matrix (combine_infmatrix f (Rep_matrix A) (Rep_matrix B))) = combine_infmatrix f (Rep_matrix A) (Rep_matrix B)"
20.320 -apply (rule Abs_matrix_inverse)
20.321 -apply (simp add: matrix_def)
20.322 -apply (rule finite_subset[of _ "(nonzero_positions (Rep_matrix A)) \<union> (nonzero_positions (Rep_matrix B))"])
20.323 -by (simp_all)
20.324 -
20.325 -text {* We need the next two lemmas only later, but it is analog to the above one, so we prove them now: *}
20.326 -lemma nonzero_positions_apply_infmatrix[simp]: "f 0 = 0 \<Longrightarrow> nonzero_positions (apply_infmatrix f A) \<subseteq> nonzero_positions A"
20.327 -by (rule subsetI, simp add: nonzero_positions_def apply_infmatrix_def, auto)
20.328 -
20.329 -lemma apply_infmatrix_closed [simp]:
20.330 - "f 0 = 0 \<Longrightarrow> Rep_matrix (Abs_matrix (apply_infmatrix f (Rep_matrix A))) = apply_infmatrix f (Rep_matrix A)"
20.331 -apply (rule Abs_matrix_inverse)
20.332 -apply (simp add: matrix_def)
20.333 -apply (rule finite_subset[of _ "nonzero_positions (Rep_matrix A)"])
20.334 -by (simp_all)
20.335 -
20.336 -lemma combine_infmatrix_assoc[simp]: "f 0 0 = 0 \<Longrightarrow> associative f \<Longrightarrow> associative (combine_infmatrix f)"
20.337 -by (simp add: associative_def combine_infmatrix_def)
20.338 -
20.339 -lemma comb: "f = g \<Longrightarrow> x = y \<Longrightarrow> f x = g y"
20.340 -by (auto)
20.341 -
20.342 -lemma combine_matrix_assoc: "f 0 0 = 0 \<Longrightarrow> associative f \<Longrightarrow> associative (combine_matrix f)"
20.343 -apply (simp(no_asm) add: associative_def combine_matrix_def, auto)
20.344 -apply (rule comb [of Abs_matrix Abs_matrix])
20.345 -by (auto, insert combine_infmatrix_assoc[of f], simp add: associative_def)
20.346 -
20.347 -lemma Rep_apply_matrix[simp]: "f 0 = 0 \<Longrightarrow> Rep_matrix (apply_matrix f A) j i = f (Rep_matrix A j i)"
20.348 -by (simp add: apply_matrix_def)
20.349 -
20.350 -lemma Rep_combine_matrix[simp]: "f 0 0 = 0 \<Longrightarrow> Rep_matrix (combine_matrix f A B) j i = f (Rep_matrix A j i) (Rep_matrix B j i)"
20.351 - by(simp add: combine_matrix_def)
20.352 -
20.353 -lemma combine_nrows_max: "f 0 0 = 0 \<Longrightarrow> nrows (combine_matrix f A B) <= max (nrows A) (nrows B)"
20.354 -by (simp add: nrows_le)
20.355 -
20.356 -lemma combine_ncols_max: "f 0 0 = 0 \<Longrightarrow> ncols (combine_matrix f A B) <= max (ncols A) (ncols B)"
20.357 -by (simp add: ncols_le)
20.358 -
20.359 -lemma combine_nrows: "f 0 0 = 0 \<Longrightarrow> nrows A <= q \<Longrightarrow> nrows B <= q \<Longrightarrow> nrows(combine_matrix f A B) <= q"
20.360 - by (simp add: nrows_le)
20.361 -
20.362 -lemma combine_ncols: "f 0 0 = 0 \<Longrightarrow> ncols A <= q \<Longrightarrow> ncols B <= q \<Longrightarrow> ncols(combine_matrix f A B) <= q"
20.363 - by (simp add: ncols_le)
20.364 -
20.365 -definition zero_r_neutral :: "('a \<Rightarrow> 'b::zero \<Rightarrow> 'a) \<Rightarrow> bool" where
20.366 - "zero_r_neutral f == ! a. f a 0 = a"
20.367 -
20.368 -definition zero_l_neutral :: "('a::zero \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool" where
20.369 - "zero_l_neutral f == ! a. f 0 a = a"
20.370 -
20.371 -definition zero_closed :: "(('a::zero) \<Rightarrow> ('b::zero) \<Rightarrow> ('c::zero)) \<Rightarrow> bool" where
20.372 - "zero_closed f == (!x. f x 0 = 0) & (!y. f 0 y = 0)"
20.373 -
20.374 -primrec foldseq :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
20.375 -where
20.376 - "foldseq f s 0 = s 0"
20.377 -| "foldseq f s (Suc n) = f (s 0) (foldseq f (% k. s(Suc k)) n)"
20.378 -
20.379 -primrec foldseq_transposed :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
20.380 -where
20.381 - "foldseq_transposed f s 0 = s 0"
20.382 -| "foldseq_transposed f s (Suc n) = f (foldseq_transposed f s n) (s (Suc n))"
20.383 -
20.384 -lemma foldseq_assoc : "associative f \<Longrightarrow> foldseq f = foldseq_transposed f"
20.385 -proof -
20.386 - assume a:"associative f"
20.387 - then have sublemma: "!! n. ! N s. N <= n \<longrightarrow> foldseq f s N = foldseq_transposed f s N"
20.388 - proof -
20.389 - fix n
20.390 - show "!N s. N <= n \<longrightarrow> foldseq f s N = foldseq_transposed f s N"
20.391 - proof (induct n)
20.392 - show "!N s. N <= 0 \<longrightarrow> foldseq f s N = foldseq_transposed f s N" by simp
20.393 - next
20.394 - fix n
20.395 - assume b:"! N s. N <= n \<longrightarrow> foldseq f s N = foldseq_transposed f s N"
20.396 - have c:"!!N s. N <= n \<Longrightarrow> foldseq f s N = foldseq_transposed f s N" by (simp add: b)
20.397 - show "! N t. N <= Suc n \<longrightarrow> foldseq f t N = foldseq_transposed f t N"
20.398 - proof (auto)
20.399 - fix N t
20.400 - assume Nsuc: "N <= Suc n"
20.401 - show "foldseq f t N = foldseq_transposed f t N"
20.402 - proof cases
20.403 - assume "N <= n"
20.404 - then show "foldseq f t N = foldseq_transposed f t N" by (simp add: b)
20.405 - next
20.406 - assume "~(N <= n)"
20.407 - with Nsuc have Nsuceq: "N = Suc n" by simp
20.408 - have neqz: "n \<noteq> 0 \<Longrightarrow> ? m. n = Suc m & Suc m <= n" by arith
20.409 - have assocf: "!! x y z. f x (f y z) = f (f x y) z" by (insert a, simp add: associative_def)
20.410 - show "foldseq f t N = foldseq_transposed f t N"
20.411 - apply (simp add: Nsuceq)
20.412 - apply (subst c)
20.413 - apply (simp)
20.414 - apply (case_tac "n = 0")
20.415 - apply (simp)
20.416 - apply (drule neqz)
20.417 - apply (erule exE)
20.418 - apply (simp)
20.419 - apply (subst assocf)
20.420 - proof -
20.421 - fix m
20.422 - assume "n = Suc m & Suc m <= n"
20.423 - then have mless: "Suc m <= n" by arith
20.424 - then have step1: "foldseq_transposed f (% k. t (Suc k)) m = foldseq f (% k. t (Suc k)) m" (is "?T1 = ?T2")
20.425 - apply (subst c)
20.426 - by simp+
20.427 - have step2: "f (t 0) ?T2 = foldseq f t (Suc m)" (is "_ = ?T3") by simp
20.428 - have step3: "?T3 = foldseq_transposed f t (Suc m)" (is "_ = ?T4")
20.429 - apply (subst c)
20.430 - by (simp add: mless)+
20.431 - have step4: "?T4 = f (foldseq_transposed f t m) (t (Suc m))" (is "_=?T5") by simp
20.432 - from step1 step2 step3 step4 show sowhat: "f (f (t 0) ?T1) (t (Suc (Suc m))) = f ?T5 (t (Suc (Suc m)))" by simp
20.433 - qed
20.434 - qed
20.435 - qed
20.436 - qed
20.437 - qed
20.438 - show "foldseq f = foldseq_transposed f" by ((rule ext)+, insert sublemma, auto)
20.439 - qed
20.440 -
20.441 -lemma foldseq_distr: "\<lbrakk>associative f; commutative f\<rbrakk> \<Longrightarrow> foldseq f (% k. f (u k) (v k)) n = f (foldseq f u n) (foldseq f v n)"
20.442 -proof -
20.443 - assume assoc: "associative f"
20.444 - assume comm: "commutative f"
20.445 - from assoc have a:"!! x y z. f (f x y) z = f x (f y z)" by (simp add: associative_def)
20.446 - from comm have b: "!! x y. f x y = f y x" by (simp add: commutative_def)
20.447 - from assoc comm have c: "!! x y z. f x (f y z) = f y (f x z)" by (simp add: commutative_def associative_def)
20.448 - have "!! n. (! u v. foldseq f (%k. f (u k) (v k)) n = f (foldseq f u n) (foldseq f v n))"
20.449 - apply (induct_tac n)
20.450 - apply (simp+, auto)
20.451 - by (simp add: a b c)
20.452 - then show "foldseq f (% k. f (u k) (v k)) n = f (foldseq f u n) (foldseq f v n)" by simp
20.453 -qed
20.454 -
20.455 -theorem "\<lbrakk>associative f; associative g; \<forall>a b c d. g (f a b) (f c d) = f (g a c) (g b d); ? x y. (f x) \<noteq> (f y); ? x y. (g x) \<noteq> (g y); f x x = x; g x x = x\<rbrakk> \<Longrightarrow> f=g | (! y. f y x = y) | (! y. g y x = y)"
20.456 -oops
20.457 -(* Model found
20.458 -
20.459 -Trying to find a model that refutes: \<lbrakk>associative f; associative g;
20.460 - \<forall>a b c d. g (f a b) (f c d) = f (g a c) (g b d); \<exists>x y. f x \<noteq> f y;
20.461 - \<exists>x y. g x \<noteq> g y; f x x = x; g x x = x\<rbrakk>
20.462 -\<Longrightarrow> f = g \<or> (\<forall>y. f y x = y) \<or> (\<forall>y. g y x = y)
20.463 -Searching for a model of size 1, translating term... invoking SAT solver... no model found.
20.464 -Searching for a model of size 2, translating term... invoking SAT solver... no model found.
20.465 -Searching for a model of size 3, translating term... invoking SAT solver...
20.466 -Model found:
20.467 -Size of types: 'a: 3
20.468 -x: a1
20.469 -g: (a0\<mapsto>(a0\<mapsto>a1, a1\<mapsto>a0, a2\<mapsto>a1), a1\<mapsto>(a0\<mapsto>a0, a1\<mapsto>a1, a2\<mapsto>a0), a2\<mapsto>(a0\<mapsto>a1, a1\<mapsto>a0, a2\<mapsto>a1))
20.470 -f: (a0\<mapsto>(a0\<mapsto>a0, a1\<mapsto>a0, a2\<mapsto>a0), a1\<mapsto>(a0\<mapsto>a1, a1\<mapsto>a1, a2\<mapsto>a1), a2\<mapsto>(a0\<mapsto>a0, a1\<mapsto>a0, a2\<mapsto>a0))
20.471 -*)
20.472 -
20.473 -lemma foldseq_zero:
20.474 -assumes fz: "f 0 0 = 0" and sz: "! i. i <= n \<longrightarrow> s i = 0"
20.475 -shows "foldseq f s n = 0"
20.476 -proof -
20.477 - have "!! n. ! s. (! i. i <= n \<longrightarrow> s i = 0) \<longrightarrow> foldseq f s n = 0"
20.478 - apply (induct_tac n)
20.479 - apply (simp)
20.480 - by (simp add: fz)
20.481 - then show "foldseq f s n = 0" by (simp add: sz)
20.482 -qed
20.483 -
20.484 -lemma foldseq_significant_positions:
20.485 - assumes p: "! i. i <= N \<longrightarrow> S i = T i"
20.486 - shows "foldseq f S N = foldseq f T N"
20.487 -proof -
20.488 - have "!! m . ! s t. (! i. i<=m \<longrightarrow> s i = t i) \<longrightarrow> foldseq f s m = foldseq f t m"
20.489 - apply (induct_tac m)
20.490 - apply (simp)
20.491 - apply (simp)
20.492 - apply (auto)
20.493 - proof -
20.494 - fix n
20.495 - fix s::"nat\<Rightarrow>'a"
20.496 - fix t::"nat\<Rightarrow>'a"
20.497 - assume a: "\<forall>s t. (\<forall>i\<le>n. s i = t i) \<longrightarrow> foldseq f s n = foldseq f t n"
20.498 - assume b: "\<forall>i\<le>Suc n. s i = t i"
20.499 - have c:"!! a b. a = b \<Longrightarrow> f (t 0) a = f (t 0) b" by blast
20.500 - have d:"!! s t. (\<forall>i\<le>n. s i = t i) \<Longrightarrow> foldseq f s n = foldseq f t n" by (simp add: a)
20.501 - show "f (t 0) (foldseq f (\<lambda>k. s (Suc k)) n) = f (t 0) (foldseq f (\<lambda>k. t (Suc k)) n)" by (rule c, simp add: d b)
20.502 - qed
20.503 - with p show ?thesis by simp
20.504 -qed
20.505 -
20.506 -lemma foldseq_tail:
20.507 - assumes "M <= N"
20.508 - shows "foldseq f S N = foldseq f (% k. (if k < M then (S k) else (foldseq f (% k. S(k+M)) (N-M)))) M"
20.509 -proof -
20.510 - have suc: "!! a b. \<lbrakk>a <= Suc b; a \<noteq> Suc b\<rbrakk> \<Longrightarrow> a <= b" by arith
20.511 - have a:"!! a b c . a = b \<Longrightarrow> f c a = f c b" by blast
20.512 - have "!! n. ! m s. m <= n \<longrightarrow> foldseq f s n = foldseq f (% k. (if k < m then (s k) else (foldseq f (% k. s(k+m)) (n-m)))) m"
20.513 - apply (induct_tac n)
20.514 - apply (simp)
20.515 - apply (simp)
20.516 - apply (auto)
20.517 - apply (case_tac "m = Suc na")
20.518 - apply (simp)
20.519 - apply (rule a)
20.520 - apply (rule foldseq_significant_positions)
20.521 - apply (auto)
20.522 - apply (drule suc, simp+)
20.523 - proof -
20.524 - fix na m s
20.525 - assume suba:"\<forall>m\<le>na. \<forall>s. foldseq f s na = foldseq f (\<lambda>k. if k < m then s k else foldseq f (\<lambda>k. s (k + m)) (na - m))m"
20.526 - assume subb:"m <= na"
20.527 - from suba have subc:"!! m s. m <= na \<Longrightarrow>foldseq f s na = foldseq f (\<lambda>k. if k < m then s k else foldseq f (\<lambda>k. s (k + m)) (na - m))m" by simp
20.528 - have subd: "foldseq f (\<lambda>k. if k < m then s (Suc k) else foldseq f (\<lambda>k. s (Suc (k + m))) (na - m)) m =
20.529 - foldseq f (% k. s(Suc k)) na"
20.530 - by (rule subc[of m "% k. s(Suc k)", THEN sym], simp add: subb)
20.531 - from subb have sube: "m \<noteq> 0 \<Longrightarrow> ? mm. m = Suc mm & mm <= na" by arith
20.532 - show "f (s 0) (foldseq f (\<lambda>k. if k < m then s (Suc k) else foldseq f (\<lambda>k. s (Suc (k + m))) (na - m)) m) =
20.533 - foldseq f (\<lambda>k. if k < m then s k else foldseq f (\<lambda>k. s (k + m)) (Suc na - m)) m"
20.534 - apply (simp add: subd)
20.535 - apply (cases "m = 0")
20.536 - apply (simp)
20.537 - apply (drule sube)
20.538 - apply (auto)
20.539 - apply (rule a)
20.540 - by (simp add: subc cong del: if_cong)
20.541 - qed
20.542 - then show ?thesis using assms by simp
20.543 -qed
20.544 -
20.545 -lemma foldseq_zerotail:
20.546 - assumes
20.547 - fz: "f 0 0 = 0"
20.548 - and sz: "! i. n <= i \<longrightarrow> s i = 0"
20.549 - and nm: "n <= m"
20.550 - shows
20.551 - "foldseq f s n = foldseq f s m"
20.552 -proof -
20.553 - show "foldseq f s n = foldseq f s m"
20.554 - apply (simp add: foldseq_tail[OF nm, of f s])
20.555 - apply (rule foldseq_significant_positions)
20.556 - apply (auto)
20.557 - apply (subst foldseq_zero)
20.558 - by (simp add: fz sz)+
20.559 -qed
20.560 -
20.561 -lemma foldseq_zerotail2:
20.562 - assumes "! x. f x 0 = x"
20.563 - and "! i. n < i \<longrightarrow> s i = 0"
20.564 - and nm: "n <= m"
20.565 - shows "foldseq f s n = foldseq f s m"
20.566 -proof -
20.567 - have "f 0 0 = 0" by (simp add: assms)
20.568 - have b:"!! m n. n <= m \<Longrightarrow> m \<noteq> n \<Longrightarrow> ? k. m-n = Suc k" by arith
20.569 - have c: "0 <= m" by simp
20.570 - have d: "!! k. k \<noteq> 0 \<Longrightarrow> ? l. k = Suc l" by arith
20.571 - show ?thesis
20.572 - apply (subst foldseq_tail[OF nm])
20.573 - apply (rule foldseq_significant_positions)
20.574 - apply (auto)
20.575 - apply (case_tac "m=n")
20.576 - apply (simp+)
20.577 - apply (drule b[OF nm])
20.578 - apply (auto)
20.579 - apply (case_tac "k=0")
20.580 - apply (simp add: assms)
20.581 - apply (drule d)
20.582 - apply (auto)
20.583 - apply (simp add: assms foldseq_zero)
20.584 - done
20.585 -qed
20.586 -
20.587 -lemma foldseq_zerostart:
20.588 - "! x. f 0 (f 0 x) = f 0 x \<Longrightarrow> ! i. i <= n \<longrightarrow> s i = 0 \<Longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))"
20.589 -proof -
20.590 - assume f00x: "! x. f 0 (f 0 x) = f 0 x"
20.591 - have "! s. (! i. i<=n \<longrightarrow> s i = 0) \<longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))"
20.592 - apply (induct n)
20.593 - apply (simp)
20.594 - apply (rule allI, rule impI)
20.595 - proof -
20.596 - fix n
20.597 - fix s
20.598 - have a:"foldseq f s (Suc (Suc n)) = f (s 0) (foldseq f (% k. s(Suc k)) (Suc n))" by simp
20.599 - assume b: "! s. ((\<forall>i\<le>n. s i = 0) \<longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n)))"
20.600 - from b have c:"!! s. (\<forall>i\<le>n. s i = 0) \<Longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))" by simp
20.601 - assume d: "! i. i <= Suc n \<longrightarrow> s i = 0"
20.602 - show "foldseq f s (Suc (Suc n)) = f 0 (s (Suc (Suc n)))"
20.603 - apply (subst a)
20.604 - apply (subst c)
20.605 - by (simp add: d f00x)+
20.606 - qed
20.607 - then show "! i. i <= n \<longrightarrow> s i = 0 \<Longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))" by simp
20.608 -qed
20.609 -
20.610 -lemma foldseq_zerostart2:
20.611 - "! x. f 0 x = x \<Longrightarrow> ! i. i < n \<longrightarrow> s i = 0 \<Longrightarrow> foldseq f s n = s n"
20.612 -proof -
20.613 - assume a:"! i. i<n \<longrightarrow> s i = 0"
20.614 - assume x:"! x. f 0 x = x"
20.615 - from x have f00x: "! x. f 0 (f 0 x) = f 0 x" by blast
20.616 - have b: "!! i l. i < Suc l = (i <= l)" by arith
20.617 - have d: "!! k. k \<noteq> 0 \<Longrightarrow> ? l. k = Suc l" by arith
20.618 - show "foldseq f s n = s n"
20.619 - apply (case_tac "n=0")
20.620 - apply (simp)
20.621 - apply (insert a)
20.622 - apply (drule d)
20.623 - apply (auto)
20.624 - apply (simp add: b)
20.625 - apply (insert f00x)
20.626 - apply (drule foldseq_zerostart)
20.627 - by (simp add: x)+
20.628 -qed
20.629 -
20.630 -lemma foldseq_almostzero:
20.631 - assumes f0x:"! x. f 0 x = x" and fx0: "! x. f x 0 = x" and s0:"! i. i \<noteq> j \<longrightarrow> s i = 0"
20.632 - shows "foldseq f s n = (if (j <= n) then (s j) else 0)"
20.633 -proof -
20.634 - from s0 have a: "! i. i < j \<longrightarrow> s i = 0" by simp
20.635 - from s0 have b: "! i. j < i \<longrightarrow> s i = 0" by simp
20.636 - show ?thesis
20.637 - apply auto
20.638 - apply (subst foldseq_zerotail2[of f, OF fx0, of j, OF b, of n, THEN sym])
20.639 - apply simp
20.640 - apply (subst foldseq_zerostart2)
20.641 - apply (simp add: f0x a)+
20.642 - apply (subst foldseq_zero)
20.643 - by (simp add: s0 f0x)+
20.644 -qed
20.645 -
20.646 -lemma foldseq_distr_unary:
20.647 - assumes "!! a b. g (f a b) = f (g a) (g b)"
20.648 - shows "g(foldseq f s n) = foldseq f (% x. g(s x)) n"
20.649 -proof -
20.650 - have "! s. g(foldseq f s n) = foldseq f (% x. g(s x)) n"
20.651 - apply (induct_tac n)
20.652 - apply (simp)
20.653 - apply (simp)
20.654 - apply (auto)
20.655 - apply (drule_tac x="% k. s (Suc k)" in spec)
20.656 - by (simp add: assms)
20.657 - then show ?thesis by simp
20.658 -qed
20.659 -
20.660 -definition mult_matrix_n :: "nat \<Rightarrow> (('a::zero) \<Rightarrow> ('b::zero) \<Rightarrow> ('c::zero)) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> 'a matrix \<Rightarrow> 'b matrix \<Rightarrow> 'c matrix" where
20.661 - "mult_matrix_n n fmul fadd A B == Abs_matrix(% j i. foldseq fadd (% k. fmul (Rep_matrix A j k) (Rep_matrix B k i)) n)"
20.662 -
20.663 -definition mult_matrix :: "(('a::zero) \<Rightarrow> ('b::zero) \<Rightarrow> ('c::zero)) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> 'a matrix \<Rightarrow> 'b matrix \<Rightarrow> 'c matrix" where
20.664 - "mult_matrix fmul fadd A B == mult_matrix_n (max (ncols A) (nrows B)) fmul fadd A B"
20.665 -
20.666 -lemma mult_matrix_n:
20.667 - assumes "ncols A \<le> n" (is ?An) "nrows B \<le> n" (is ?Bn) "fadd 0 0 = 0" "fmul 0 0 = 0"
20.668 - shows c:"mult_matrix fmul fadd A B = mult_matrix_n n fmul fadd A B"
20.669 -proof -
20.670 - show ?thesis using assms
20.671 - apply (simp add: mult_matrix_def mult_matrix_n_def)
20.672 - apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
20.673 - apply (rule foldseq_zerotail, simp_all add: nrows_le ncols_le assms)
20.674 - done
20.675 -qed
20.676 -
20.677 -lemma mult_matrix_nm:
20.678 - assumes "ncols A <= n" "nrows B <= n" "ncols A <= m" "nrows B <= m" "fadd 0 0 = 0" "fmul 0 0 = 0"
20.679 - shows "mult_matrix_n n fmul fadd A B = mult_matrix_n m fmul fadd A B"
20.680 -proof -
20.681 - from assms have "mult_matrix_n n fmul fadd A B = mult_matrix fmul fadd A B"
20.682 - by (simp add: mult_matrix_n)
20.683 - also from assms have "\<dots> = mult_matrix_n m fmul fadd A B"
20.684 - by (simp add: mult_matrix_n[THEN sym])
20.685 - finally show "mult_matrix_n n fmul fadd A B = mult_matrix_n m fmul fadd A B" by simp
20.686 -qed
20.687 -
20.688 -definition r_distributive :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool" where
20.689 - "r_distributive fmul fadd == ! a u v. fmul a (fadd u v) = fadd (fmul a u) (fmul a v)"
20.690 -
20.691 -definition l_distributive :: "('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
20.692 - "l_distributive fmul fadd == ! a u v. fmul (fadd u v) a = fadd (fmul u a) (fmul v a)"
20.693 -
20.694 -definition distributive :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
20.695 - "distributive fmul fadd == l_distributive fmul fadd & r_distributive fmul fadd"
20.696 -
20.697 -lemma max1: "!! a x y. (a::nat) <= x \<Longrightarrow> a <= max x y" by (arith)
20.698 -lemma max2: "!! b x y. (b::nat) <= y \<Longrightarrow> b <= max x y" by (arith)
20.699 -
20.700 -lemma r_distributive_matrix:
20.701 - assumes
20.702 - "r_distributive fmul fadd"
20.703 - "associative fadd"
20.704 - "commutative fadd"
20.705 - "fadd 0 0 = 0"
20.706 - "! a. fmul a 0 = 0"
20.707 - "! a. fmul 0 a = 0"
20.708 - shows "r_distributive (mult_matrix fmul fadd) (combine_matrix fadd)"
20.709 -proof -
20.710 - from assms show ?thesis
20.711 - apply (simp add: r_distributive_def mult_matrix_def, auto)
20.712 - proof -
20.713 - fix a::"'a matrix"
20.714 - fix u::"'b matrix"
20.715 - fix v::"'b matrix"
20.716 - let ?mx = "max (ncols a) (max (nrows u) (nrows v))"
20.717 - from assms show "mult_matrix_n (max (ncols a) (nrows (combine_matrix fadd u v))) fmul fadd a (combine_matrix fadd u v) =
20.718 - combine_matrix fadd (mult_matrix_n (max (ncols a) (nrows u)) fmul fadd a u) (mult_matrix_n (max (ncols a) (nrows v)) fmul fadd a v)"
20.719 - apply (subst mult_matrix_nm[of _ _ _ ?mx fadd fmul])
20.720 - apply (simp add: max1 max2 combine_nrows combine_ncols)+
20.721 - apply (subst mult_matrix_nm[of _ _ v ?mx fadd fmul])
20.722 - apply (simp add: max1 max2 combine_nrows combine_ncols)+
20.723 - apply (subst mult_matrix_nm[of _ _ u ?mx fadd fmul])
20.724 - apply (simp add: max1 max2 combine_nrows combine_ncols)+
20.725 - apply (simp add: mult_matrix_n_def r_distributive_def foldseq_distr[of fadd])
20.726 - apply (simp add: combine_matrix_def combine_infmatrix_def)
20.727 - apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
20.728 - apply (simplesubst RepAbs_matrix)
20.729 - apply (simp, auto)
20.730 - apply (rule exI[of _ "nrows a"], simp add: nrows_le foldseq_zero)
20.731 - apply (rule exI[of _ "ncols v"], simp add: ncols_le foldseq_zero)
20.732 - apply (subst RepAbs_matrix)
20.733 - apply (simp, auto)
20.734 - apply (rule exI[of _ "nrows a"], simp add: nrows_le foldseq_zero)
20.735 - apply (rule exI[of _ "ncols u"], simp add: ncols_le foldseq_zero)
20.736 - done
20.737 - qed
20.738 -qed
20.739 -
20.740 -lemma l_distributive_matrix:
20.741 - assumes
20.742 - "l_distributive fmul fadd"
20.743 - "associative fadd"
20.744 - "commutative fadd"
20.745 - "fadd 0 0 = 0"
20.746 - "! a. fmul a 0 = 0"
20.747 - "! a. fmul 0 a = 0"
20.748 - shows "l_distributive (mult_matrix fmul fadd) (combine_matrix fadd)"
20.749 -proof -
20.750 - from assms show ?thesis
20.751 - apply (simp add: l_distributive_def mult_matrix_def, auto)
20.752 - proof -
20.753 - fix a::"'b matrix"
20.754 - fix u::"'a matrix"
20.755 - fix v::"'a matrix"
20.756 - let ?mx = "max (nrows a) (max (ncols u) (ncols v))"
20.757 - from assms show "mult_matrix_n (max (ncols (combine_matrix fadd u v)) (nrows a)) fmul fadd (combine_matrix fadd u v) a =
20.758 - combine_matrix fadd (mult_matrix_n (max (ncols u) (nrows a)) fmul fadd u a) (mult_matrix_n (max (ncols v) (nrows a)) fmul fadd v a)"
20.759 - apply (subst mult_matrix_nm[of v _ _ ?mx fadd fmul])
20.760 - apply (simp add: max1 max2 combine_nrows combine_ncols)+
20.761 - apply (subst mult_matrix_nm[of u _ _ ?mx fadd fmul])
20.762 - apply (simp add: max1 max2 combine_nrows combine_ncols)+
20.763 - apply (subst mult_matrix_nm[of _ _ _ ?mx fadd fmul])
20.764 - apply (simp add: max1 max2 combine_nrows combine_ncols)+
20.765 - apply (simp add: mult_matrix_n_def l_distributive_def foldseq_distr[of fadd])
20.766 - apply (simp add: combine_matrix_def combine_infmatrix_def)
20.767 - apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
20.768 - apply (simplesubst RepAbs_matrix)
20.769 - apply (simp, auto)
20.770 - apply (rule exI[of _ "nrows v"], simp add: nrows_le foldseq_zero)
20.771 - apply (rule exI[of _ "ncols a"], simp add: ncols_le foldseq_zero)
20.772 - apply (subst RepAbs_matrix)
20.773 - apply (simp, auto)
20.774 - apply (rule exI[of _ "nrows u"], simp add: nrows_le foldseq_zero)
20.775 - apply (rule exI[of _ "ncols a"], simp add: ncols_le foldseq_zero)
20.776 - done
20.777 - qed
20.778 -qed
20.779 -
20.780 -instantiation matrix :: (zero) zero
20.781 -begin
20.782 -
20.783 -definition zero_matrix_def: "0 = Abs_matrix (\<lambda>j i. 0)"
20.784 -
20.785 -instance ..
20.786 -
20.787 -end
20.788 -
20.789 -lemma Rep_zero_matrix_def[simp]: "Rep_matrix 0 j i = 0"
20.790 - apply (simp add: zero_matrix_def)
20.791 - apply (subst RepAbs_matrix)
20.792 - by (auto)
20.793 -
20.794 -lemma zero_matrix_def_nrows[simp]: "nrows 0 = 0"
20.795 -proof -
20.796 - have a:"!! (x::nat). x <= 0 \<Longrightarrow> x = 0" by (arith)
20.797 - show "nrows 0 = 0" by (rule a, subst nrows_le, simp)
20.798 -qed
20.799 -
20.800 -lemma zero_matrix_def_ncols[simp]: "ncols 0 = 0"
20.801 -proof -
20.802 - have a:"!! (x::nat). x <= 0 \<Longrightarrow> x = 0" by (arith)
20.803 - show "ncols 0 = 0" by (rule a, subst ncols_le, simp)
20.804 -qed
20.805 -
20.806 -lemma combine_matrix_zero_l_neutral: "zero_l_neutral f \<Longrightarrow> zero_l_neutral (combine_matrix f)"
20.807 - by (simp add: zero_l_neutral_def combine_matrix_def combine_infmatrix_def)
20.808 -
20.809 -lemma combine_matrix_zero_r_neutral: "zero_r_neutral f \<Longrightarrow> zero_r_neutral (combine_matrix f)"
20.810 - by (simp add: zero_r_neutral_def combine_matrix_def combine_infmatrix_def)
20.811 -
20.812 -lemma mult_matrix_zero_closed: "\<lbrakk>fadd 0 0 = 0; zero_closed fmul\<rbrakk> \<Longrightarrow> zero_closed (mult_matrix fmul fadd)"
20.813 - apply (simp add: zero_closed_def mult_matrix_def mult_matrix_n_def)
20.814 - apply (auto)
20.815 - by (subst foldseq_zero, (simp add: zero_matrix_def)+)+
20.816 -
20.817 -lemma mult_matrix_n_zero_right[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul a 0 = 0\<rbrakk> \<Longrightarrow> mult_matrix_n n fmul fadd A 0 = 0"
20.818 - apply (simp add: mult_matrix_n_def)
20.819 - apply (subst foldseq_zero)
20.820 - by (simp_all add: zero_matrix_def)
20.821 -
20.822 -lemma mult_matrix_n_zero_left[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul 0 a = 0\<rbrakk> \<Longrightarrow> mult_matrix_n n fmul fadd 0 A = 0"
20.823 - apply (simp add: mult_matrix_n_def)
20.824 - apply (subst foldseq_zero)
20.825 - by (simp_all add: zero_matrix_def)
20.826 -
20.827 -lemma mult_matrix_zero_left[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul 0 a = 0\<rbrakk> \<Longrightarrow> mult_matrix fmul fadd 0 A = 0"
20.828 -by (simp add: mult_matrix_def)
20.829 -
20.830 -lemma mult_matrix_zero_right[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul a 0 = 0\<rbrakk> \<Longrightarrow> mult_matrix fmul fadd A 0 = 0"
20.831 -by (simp add: mult_matrix_def)
20.832 -
20.833 -lemma apply_matrix_zero[simp]: "f 0 = 0 \<Longrightarrow> apply_matrix f 0 = 0"
20.834 - apply (simp add: apply_matrix_def apply_infmatrix_def)
20.835 - by (simp add: zero_matrix_def)
20.836 -
20.837 -lemma combine_matrix_zero: "f 0 0 = 0 \<Longrightarrow> combine_matrix f 0 0 = 0"
20.838 - apply (simp add: combine_matrix_def combine_infmatrix_def)
20.839 - by (simp add: zero_matrix_def)
20.840 -
20.841 -lemma transpose_matrix_zero[simp]: "transpose_matrix 0 = 0"
20.842 -apply (simp add: transpose_matrix_def zero_matrix_def RepAbs_matrix)
20.843 -apply (subst Rep_matrix_inject[symmetric], (rule ext)+)
20.844 -apply (simp add: RepAbs_matrix)
20.845 -done
20.846 -
20.847 -lemma apply_zero_matrix_def[simp]: "apply_matrix (% x. 0) A = 0"
20.848 - apply (simp add: apply_matrix_def apply_infmatrix_def)
20.849 - by (simp add: zero_matrix_def)
20.850 -
20.851 -definition singleton_matrix :: "nat \<Rightarrow> nat \<Rightarrow> ('a::zero) \<Rightarrow> 'a matrix" where
20.852 - "singleton_matrix j i a == Abs_matrix(% m n. if j = m & i = n then a else 0)"
20.853 -
20.854 -definition move_matrix :: "('a::zero) matrix \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a matrix" where
20.855 - "move_matrix A y x == Abs_matrix(% j i. if (((int j)-y) < 0) | (((int i)-x) < 0) then 0 else Rep_matrix A (nat ((int j)-y)) (nat ((int i)-x)))"
20.856 -
20.857 -definition take_rows :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
20.858 - "take_rows A r == Abs_matrix(% j i. if (j < r) then (Rep_matrix A j i) else 0)"
20.859 -
20.860 -definition take_columns :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
20.861 - "take_columns A c == Abs_matrix(% j i. if (i < c) then (Rep_matrix A j i) else 0)"
20.862 -
20.863 -definition column_of_matrix :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
20.864 - "column_of_matrix A n == take_columns (move_matrix A 0 (- int n)) 1"
20.865 -
20.866 -definition row_of_matrix :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
20.867 - "row_of_matrix A m == take_rows (move_matrix A (- int m) 0) 1"
20.868 -
20.869 -lemma Rep_singleton_matrix[simp]: "Rep_matrix (singleton_matrix j i e) m n = (if j = m & i = n then e else 0)"
20.870 -apply (simp add: singleton_matrix_def)
20.871 -apply (auto)
20.872 -apply (subst RepAbs_matrix)
20.873 -apply (rule exI[of _ "Suc m"], simp)
20.874 -apply (rule exI[of _ "Suc n"], simp+)
20.875 -by (subst RepAbs_matrix, rule exI[of _ "Suc j"], simp, rule exI[of _ "Suc i"], simp+)+
20.876 -
20.877 -lemma apply_singleton_matrix[simp]: "f 0 = 0 \<Longrightarrow> apply_matrix f (singleton_matrix j i x) = (singleton_matrix j i (f x))"
20.878 -apply (subst Rep_matrix_inject[symmetric])
20.879 -apply (rule ext)+
20.880 -apply (simp)
20.881 -done
20.882 -
20.883 -lemma singleton_matrix_zero[simp]: "singleton_matrix j i 0 = 0"
20.884 - by (simp add: singleton_matrix_def zero_matrix_def)
20.885 -
20.886 -lemma nrows_singleton[simp]: "nrows(singleton_matrix j i e) = (if e = 0 then 0 else Suc j)"
20.887 -proof-
20.888 -have th: "\<not> (\<forall>m. m \<le> j)" "\<exists>n. \<not> n \<le> i" by arith+
20.889 -from th show ?thesis
20.890 -apply (auto)
20.891 -apply (rule le_antisym)
20.892 -apply (subst nrows_le)
20.893 -apply (simp add: singleton_matrix_def, auto)
20.894 -apply (subst RepAbs_matrix)
20.895 -apply auto
20.896 -apply (simp add: Suc_le_eq)
20.897 -apply (rule not_leE)
20.898 -apply (subst nrows_le)
20.899 -by simp
20.900 -qed
20.901 -
20.902 -lemma ncols_singleton[simp]: "ncols(singleton_matrix j i e) = (if e = 0 then 0 else Suc i)"
20.903 -proof-
20.904 -have th: "\<not> (\<forall>m. m \<le> j)" "\<exists>n. \<not> n \<le> i" by arith+
20.905 -from th show ?thesis
20.906 -apply (auto)
20.907 -apply (rule le_antisym)
20.908 -apply (subst ncols_le)
20.909 -apply (simp add: singleton_matrix_def, auto)
20.910 -apply (subst RepAbs_matrix)
20.911 -apply auto
20.912 -apply (simp add: Suc_le_eq)
20.913 -apply (rule not_leE)
20.914 -apply (subst ncols_le)
20.915 -by simp
20.916 -qed
20.917 -
20.918 -lemma combine_singleton: "f 0 0 = 0 \<Longrightarrow> combine_matrix f (singleton_matrix j i a) (singleton_matrix j i b) = singleton_matrix j i (f a b)"
20.919 -apply (simp add: singleton_matrix_def combine_matrix_def combine_infmatrix_def)
20.920 -apply (subst RepAbs_matrix)
20.921 -apply (rule exI[of _ "Suc j"], simp)
20.922 -apply (rule exI[of _ "Suc i"], simp)
20.923 -apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
20.924 -apply (subst RepAbs_matrix)
20.925 -apply (rule exI[of _ "Suc j"], simp)
20.926 -apply (rule exI[of _ "Suc i"], simp)
20.927 -by simp
20.928 -
20.929 -lemma transpose_singleton[simp]: "transpose_matrix (singleton_matrix j i a) = singleton_matrix i j a"
20.930 -apply (subst Rep_matrix_inject[symmetric], (rule ext)+)
20.931 -apply (simp)
20.932 -done
20.933 -
20.934 -lemma Rep_move_matrix[simp]:
20.935 - "Rep_matrix (move_matrix A y x) j i =
20.936 - (if (((int j)-y) < 0) | (((int i)-x) < 0) then 0 else Rep_matrix A (nat((int j)-y)) (nat((int i)-x)))"
20.937 -apply (simp add: move_matrix_def)
20.938 -apply (auto)
20.939 -by (subst RepAbs_matrix,
20.940 - rule exI[of _ "(nrows A)+(nat (abs y))"], auto, rule nrows, arith,
20.941 - rule exI[of _ "(ncols A)+(nat (abs x))"], auto, rule ncols, arith)+
20.942 -
20.943 -lemma move_matrix_0_0[simp]: "move_matrix A 0 0 = A"
20.944 -by (simp add: move_matrix_def)
20.945 -
20.946 -lemma move_matrix_ortho: "move_matrix A j i = move_matrix (move_matrix A j 0) 0 i"
20.947 -apply (subst Rep_matrix_inject[symmetric])
20.948 -apply (rule ext)+
20.949 -apply (simp)
20.950 -done
20.951 -
20.952 -lemma transpose_move_matrix[simp]:
20.953 - "transpose_matrix (move_matrix A x y) = move_matrix (transpose_matrix A) y x"
20.954 -apply (subst Rep_matrix_inject[symmetric], (rule ext)+)
20.955 -apply (simp)
20.956 -done
20.957 -
20.958 -lemma move_matrix_singleton[simp]: "move_matrix (singleton_matrix u v x) j i =
20.959 - (if (j + int u < 0) | (i + int v < 0) then 0 else (singleton_matrix (nat (j + int u)) (nat (i + int v)) x))"
20.960 - apply (subst Rep_matrix_inject[symmetric])
20.961 - apply (rule ext)+
20.962 - apply (case_tac "j + int u < 0")
20.963 - apply (simp, arith)
20.964 - apply (case_tac "i + int v < 0")
20.965 - apply (simp, arith)
20.966 - apply simp
20.967 - apply arith
20.968 - done
20.969 -
20.970 -lemma Rep_take_columns[simp]:
20.971 - "Rep_matrix (take_columns A c) j i =
20.972 - (if i < c then (Rep_matrix A j i) else 0)"
20.973 -apply (simp add: take_columns_def)
20.974 -apply (simplesubst RepAbs_matrix)
20.975 -apply (rule exI[of _ "nrows A"], auto, simp add: nrows_le)
20.976 -apply (rule exI[of _ "ncols A"], auto, simp add: ncols_le)
20.977 -done
20.978 -
20.979 -lemma Rep_take_rows[simp]:
20.980 - "Rep_matrix (take_rows A r) j i =
20.981 - (if j < r then (Rep_matrix A j i) else 0)"
20.982 -apply (simp add: take_rows_def)
20.983 -apply (simplesubst RepAbs_matrix)
20.984 -apply (rule exI[of _ "nrows A"], auto, simp add: nrows_le)
20.985 -apply (rule exI[of _ "ncols A"], auto, simp add: ncols_le)
20.986 -done
20.987 -
20.988 -lemma Rep_column_of_matrix[simp]:
20.989 - "Rep_matrix (column_of_matrix A c) j i = (if i = 0 then (Rep_matrix A j c) else 0)"
20.990 - by (simp add: column_of_matrix_def)
20.991 -
20.992 -lemma Rep_row_of_matrix[simp]:
20.993 - "Rep_matrix (row_of_matrix A r) j i = (if j = 0 then (Rep_matrix A r i) else 0)"
20.994 - by (simp add: row_of_matrix_def)
20.995 -
20.996 -lemma column_of_matrix: "ncols A <= n \<Longrightarrow> column_of_matrix A n = 0"
20.997 -apply (subst Rep_matrix_inject[THEN sym])
20.998 -apply (rule ext)+
20.999 -by (simp add: ncols)
20.1000 -
20.1001 -lemma row_of_matrix: "nrows A <= n \<Longrightarrow> row_of_matrix A n = 0"
20.1002 -apply (subst Rep_matrix_inject[THEN sym])
20.1003 -apply (rule ext)+
20.1004 -by (simp add: nrows)
20.1005 -
20.1006 -lemma mult_matrix_singleton_right[simp]:
20.1007 - assumes
20.1008 - "! x. fmul x 0 = 0"
20.1009 - "! x. fmul 0 x = 0"
20.1010 - "! x. fadd 0 x = x"
20.1011 - "! x. fadd x 0 = x"
20.1012 - shows "(mult_matrix fmul fadd A (singleton_matrix j i e)) = apply_matrix (% x. fmul x e) (move_matrix (column_of_matrix A j) 0 (int i))"
20.1013 - apply (simp add: mult_matrix_def)
20.1014 - apply (subst mult_matrix_nm[of _ _ _ "max (ncols A) (Suc j)"])
20.1015 - apply (auto)
20.1016 - apply (simp add: assms)+
20.1017 - apply (simp add: mult_matrix_n_def apply_matrix_def apply_infmatrix_def)
20.1018 - apply (rule comb[of "Abs_matrix" "Abs_matrix"], auto, (rule ext)+)
20.1019 - apply (subst foldseq_almostzero[of _ j])
20.1020 - apply (simp add: assms)+
20.1021 - apply (auto)
20.1022 - done
20.1023 -
20.1024 -lemma mult_matrix_ext:
20.1025 - assumes
20.1026 - eprem:
20.1027 - "? e. (! a b. a \<noteq> b \<longrightarrow> fmul a e \<noteq> fmul b e)"
20.1028 - and fprems:
20.1029 - "! a. fmul 0 a = 0"
20.1030 - "! a. fmul a 0 = 0"
20.1031 - "! a. fadd a 0 = a"
20.1032 - "! a. fadd 0 a = a"
20.1033 - and contraprems:
20.1034 - "mult_matrix fmul fadd A = mult_matrix fmul fadd B"
20.1035 - shows
20.1036 - "A = B"
20.1037 -proof(rule contrapos_np[of "False"], simp)
20.1038 - assume a: "A \<noteq> B"
20.1039 - have b: "!! f g. (! x y. f x y = g x y) \<Longrightarrow> f = g" by ((rule ext)+, auto)
20.1040 - have "? j i. (Rep_matrix A j i) \<noteq> (Rep_matrix B j i)"
20.1041 - apply (rule contrapos_np[of "False"], simp+)
20.1042 - apply (insert b[of "Rep_matrix A" "Rep_matrix B"], simp)
20.1043 - by (simp add: Rep_matrix_inject a)
20.1044 - then obtain J I where c:"(Rep_matrix A J I) \<noteq> (Rep_matrix B J I)" by blast
20.1045 - from eprem obtain e where eprops:"(! a b. a \<noteq> b \<longrightarrow> fmul a e \<noteq> fmul b e)" by blast
20.1046 - let ?S = "singleton_matrix I 0 e"
20.1047 - let ?comp = "mult_matrix fmul fadd"
20.1048 - have d: "!!x f g. f = g \<Longrightarrow> f x = g x" by blast
20.1049 - have e: "(% x. fmul x e) 0 = 0" by (simp add: assms)
20.1050 - have "~(?comp A ?S = ?comp B ?S)"
20.1051 - apply (rule notI)
20.1052 - apply (simp add: fprems eprops)
20.1053 - apply (simp add: Rep_matrix_inject[THEN sym])
20.1054 - apply (drule d[of _ _ "J"], drule d[of _ _ "0"])
20.1055 - by (simp add: e c eprops)
20.1056 - with contraprems show "False" by simp
20.1057 -qed
20.1058 -
20.1059 -definition foldmatrix :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a infmatrix) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
20.1060 - "foldmatrix f g A m n == foldseq_transposed g (% j. foldseq f (A j) n) m"
20.1061 -
20.1062 -definition foldmatrix_transposed :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a infmatrix) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
20.1063 - "foldmatrix_transposed f g A m n == foldseq g (% j. foldseq_transposed f (A j) n) m"
20.1064 -
20.1065 -lemma foldmatrix_transpose:
20.1066 - assumes
20.1067 - "! a b c d. g(f a b) (f c d) = f (g a c) (g b d)"
20.1068 - shows
20.1069 - "foldmatrix f g A m n = foldmatrix_transposed g f (transpose_infmatrix A) n m"
20.1070 -proof -
20.1071 - have forall:"!! P x. (! x. P x) \<Longrightarrow> P x" by auto
20.1072 - have tworows:"! A. foldmatrix f g A 1 n = foldmatrix_transposed g f (transpose_infmatrix A) n 1"
20.1073 - apply (induct n)
20.1074 - apply (simp add: foldmatrix_def foldmatrix_transposed_def assms)+
20.1075 - apply (auto)
20.1076 - by (drule_tac x="(% j i. A j (Suc i))" in forall, simp)
20.1077 - show "foldmatrix f g A m n = foldmatrix_transposed g f (transpose_infmatrix A) n m"
20.1078 - apply (simp add: foldmatrix_def foldmatrix_transposed_def)
20.1079 - apply (induct m, simp)
20.1080 - apply (simp)
20.1081 - apply (insert tworows)
20.1082 - apply (drule_tac x="% j i. (if j = 0 then (foldseq_transposed g (\<lambda>u. A u i) m) else (A (Suc m) i))" in spec)
20.1083 - by (simp add: foldmatrix_def foldmatrix_transposed_def)
20.1084 -qed
20.1085 -
20.1086 -lemma foldseq_foldseq:
20.1087 -assumes
20.1088 - "associative f"
20.1089 - "associative g"
20.1090 - "! a b c d. g(f a b) (f c d) = f (g a c) (g b d)"
20.1091 -shows
20.1092 - "foldseq g (% j. foldseq f (A j) n) m = foldseq f (% j. foldseq g ((transpose_infmatrix A) j) m) n"
20.1093 - apply (insert foldmatrix_transpose[of g f A m n])
20.1094 - by (simp add: foldmatrix_def foldmatrix_transposed_def foldseq_assoc[THEN sym] assms)
20.1095 -
20.1096 -lemma mult_n_nrows:
20.1097 -assumes
20.1098 -"! a. fmul 0 a = 0"
20.1099 -"! a. fmul a 0 = 0"
20.1100 -"fadd 0 0 = 0"
20.1101 -shows "nrows (mult_matrix_n n fmul fadd A B) \<le> nrows A"
20.1102 -apply (subst nrows_le)
20.1103 -apply (simp add: mult_matrix_n_def)
20.1104 -apply (subst RepAbs_matrix)
20.1105 -apply (rule_tac x="nrows A" in exI)
20.1106 -apply (simp add: nrows assms foldseq_zero)
20.1107 -apply (rule_tac x="ncols B" in exI)
20.1108 -apply (simp add: ncols assms foldseq_zero)
20.1109 -apply (simp add: nrows assms foldseq_zero)
20.1110 -done
20.1111 -
20.1112 -lemma mult_n_ncols:
20.1113 -assumes
20.1114 -"! a. fmul 0 a = 0"
20.1115 -"! a. fmul a 0 = 0"
20.1116 -"fadd 0 0 = 0"
20.1117 -shows "ncols (mult_matrix_n n fmul fadd A B) \<le> ncols B"
20.1118 -apply (subst ncols_le)
20.1119 -apply (simp add: mult_matrix_n_def)
20.1120 -apply (subst RepAbs_matrix)
20.1121 -apply (rule_tac x="nrows A" in exI)
20.1122 -apply (simp add: nrows assms foldseq_zero)
20.1123 -apply (rule_tac x="ncols B" in exI)
20.1124 -apply (simp add: ncols assms foldseq_zero)
20.1125 -apply (simp add: ncols assms foldseq_zero)
20.1126 -done
20.1127 -
20.1128 -lemma mult_nrows:
20.1129 -assumes
20.1130 -"! a. fmul 0 a = 0"
20.1131 -"! a. fmul a 0 = 0"
20.1132 -"fadd 0 0 = 0"
20.1133 -shows "nrows (mult_matrix fmul fadd A B) \<le> nrows A"
20.1134 -by (simp add: mult_matrix_def mult_n_nrows assms)
20.1135 -
20.1136 -lemma mult_ncols:
20.1137 -assumes
20.1138 -"! a. fmul 0 a = 0"
20.1139 -"! a. fmul a 0 = 0"
20.1140 -"fadd 0 0 = 0"
20.1141 -shows "ncols (mult_matrix fmul fadd A B) \<le> ncols B"
20.1142 -by (simp add: mult_matrix_def mult_n_ncols assms)
20.1143 -
20.1144 -lemma nrows_move_matrix_le: "nrows (move_matrix A j i) <= nat((int (nrows A)) + j)"
20.1145 - apply (auto simp add: nrows_le)
20.1146 - apply (rule nrows)
20.1147 - apply (arith)
20.1148 - done
20.1149 -
20.1150 -lemma ncols_move_matrix_le: "ncols (move_matrix A j i) <= nat((int (ncols A)) + i)"
20.1151 - apply (auto simp add: ncols_le)
20.1152 - apply (rule ncols)
20.1153 - apply (arith)
20.1154 - done
20.1155 -
20.1156 -lemma mult_matrix_assoc:
20.1157 - assumes
20.1158 - "! a. fmul1 0 a = 0"
20.1159 - "! a. fmul1 a 0 = 0"
20.1160 - "! a. fmul2 0 a = 0"
20.1161 - "! a. fmul2 a 0 = 0"
20.1162 - "fadd1 0 0 = 0"
20.1163 - "fadd2 0 0 = 0"
20.1164 - "! a b c d. fadd2 (fadd1 a b) (fadd1 c d) = fadd1 (fadd2 a c) (fadd2 b d)"
20.1165 - "associative fadd1"
20.1166 - "associative fadd2"
20.1167 - "! a b c. fmul2 (fmul1 a b) c = fmul1 a (fmul2 b c)"
20.1168 - "! a b c. fmul2 (fadd1 a b) c = fadd1 (fmul2 a c) (fmul2 b c)"
20.1169 - "! a b c. fmul1 c (fadd2 a b) = fadd2 (fmul1 c a) (fmul1 c b)"
20.1170 - shows "mult_matrix fmul2 fadd2 (mult_matrix fmul1 fadd1 A B) C = mult_matrix fmul1 fadd1 A (mult_matrix fmul2 fadd2 B C)"
20.1171 -proof -
20.1172 - have comb_left: "!! A B x y. A = B \<Longrightarrow> (Rep_matrix (Abs_matrix A)) x y = (Rep_matrix(Abs_matrix B)) x y" by blast
20.1173 - have fmul2fadd1fold: "!! x s n. fmul2 (foldseq fadd1 s n) x = foldseq fadd1 (% k. fmul2 (s k) x) n"
20.1174 - by (rule_tac g1 = "% y. fmul2 y x" in ssubst [OF foldseq_distr_unary], insert assms, simp_all)
20.1175 - have fmul1fadd2fold: "!! x s n. fmul1 x (foldseq fadd2 s n) = foldseq fadd2 (% k. fmul1 x (s k)) n"
20.1176 - using assms by (rule_tac g1 = "% y. fmul1 x y" in ssubst [OF foldseq_distr_unary], simp_all)
20.1177 - let ?N = "max (ncols A) (max (ncols B) (max (nrows B) (nrows C)))"
20.1178 - show ?thesis
20.1179 - apply (simp add: Rep_matrix_inject[THEN sym])
20.1180 - apply (rule ext)+
20.1181 - apply (simp add: mult_matrix_def)
20.1182 - apply (simplesubst mult_matrix_nm[of _ "max (ncols (mult_matrix_n (max (ncols A) (nrows B)) fmul1 fadd1 A B)) (nrows C)" _ "max (ncols B) (nrows C)"])
20.1183 - apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
20.1184 - apply (simplesubst mult_matrix_nm[of _ "max (ncols A) (nrows (mult_matrix_n (max (ncols B) (nrows C)) fmul2 fadd2 B C))" _ "max (ncols A) (nrows B)"])
20.1185 - apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
20.1186 - apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
20.1187 - apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
20.1188 - apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
20.1189 - apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
20.1190 - apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
20.1191 - apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
20.1192 - apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
20.1193 - apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
20.1194 - apply (simp add: mult_matrix_n_def)
20.1195 - apply (rule comb_left)
20.1196 - apply ((rule ext)+, simp)
20.1197 - apply (simplesubst RepAbs_matrix)
20.1198 - apply (rule exI[of _ "nrows B"])
20.1199 - apply (simp add: nrows assms foldseq_zero)
20.1200 - apply (rule exI[of _ "ncols C"])
20.1201 - apply (simp add: assms ncols foldseq_zero)
20.1202 - apply (subst RepAbs_matrix)
20.1203 - apply (rule exI[of _ "nrows A"])
20.1204 - apply (simp add: nrows assms foldseq_zero)
20.1205 - apply (rule exI[of _ "ncols B"])
20.1206 - apply (simp add: assms ncols foldseq_zero)
20.1207 - apply (simp add: fmul2fadd1fold fmul1fadd2fold assms)
20.1208 - apply (subst foldseq_foldseq)
20.1209 - apply (simp add: assms)+
20.1210 - apply (simp add: transpose_infmatrix)
20.1211 - done
20.1212 -qed
20.1213 -
20.1214 -lemma
20.1215 - assumes
20.1216 - "! a. fmul1 0 a = 0"
20.1217 - "! a. fmul1 a 0 = 0"
20.1218 - "! a. fmul2 0 a = 0"
20.1219 - "! a. fmul2 a 0 = 0"
20.1220 - "fadd1 0 0 = 0"
20.1221 - "fadd2 0 0 = 0"
20.1222 - "! a b c d. fadd2 (fadd1 a b) (fadd1 c d) = fadd1 (fadd2 a c) (fadd2 b d)"
20.1223 - "associative fadd1"
20.1224 - "associative fadd2"
20.1225 - "! a b c. fmul2 (fmul1 a b) c = fmul1 a (fmul2 b c)"
20.1226 - "! a b c. fmul2 (fadd1 a b) c = fadd1 (fmul2 a c) (fmul2 b c)"
20.1227 - "! a b c. fmul1 c (fadd2 a b) = fadd2 (fmul1 c a) (fmul1 c b)"
20.1228 - shows
20.1229 - "(mult_matrix fmul1 fadd1 A) o (mult_matrix fmul2 fadd2 B) = mult_matrix fmul2 fadd2 (mult_matrix fmul1 fadd1 A B)"
20.1230 -apply (rule ext)+
20.1231 -apply (simp add: comp_def )
20.1232 -apply (simp add: mult_matrix_assoc assms)
20.1233 -done
20.1234 -
20.1235 -lemma mult_matrix_assoc_simple:
20.1236 - assumes
20.1237 - "! a. fmul 0 a = 0"
20.1238 - "! a. fmul a 0 = 0"
20.1239 - "fadd 0 0 = 0"
20.1240 - "associative fadd"
20.1241 - "commutative fadd"
20.1242 - "associative fmul"
20.1243 - "distributive fmul fadd"
20.1244 - shows "mult_matrix fmul fadd (mult_matrix fmul fadd A B) C = mult_matrix fmul fadd A (mult_matrix fmul fadd B C)"
20.1245 -proof -
20.1246 - have "!! a b c d. fadd (fadd a b) (fadd c d) = fadd (fadd a c) (fadd b d)"
20.1247 - using assms by (simp add: associative_def commutative_def)
20.1248 - then show ?thesis
20.1249 - apply (subst mult_matrix_assoc)
20.1250 - using assms
20.1251 - apply simp_all
20.1252 - apply (simp_all add: associative_def distributive_def l_distributive_def r_distributive_def)
20.1253 - done
20.1254 -qed
20.1255 -
20.1256 -lemma transpose_apply_matrix: "f 0 = 0 \<Longrightarrow> transpose_matrix (apply_matrix f A) = apply_matrix f (transpose_matrix A)"
20.1257 -apply (simp add: Rep_matrix_inject[THEN sym])
20.1258 -apply (rule ext)+
20.1259 -by simp
20.1260 -
20.1261 -lemma transpose_combine_matrix: "f 0 0 = 0 \<Longrightarrow> transpose_matrix (combine_matrix f A B) = combine_matrix f (transpose_matrix A) (transpose_matrix B)"
20.1262 -apply (simp add: Rep_matrix_inject[THEN sym])
20.1263 -apply (rule ext)+
20.1264 -by simp
20.1265 -
20.1266 -lemma Rep_mult_matrix:
20.1267 - assumes
20.1268 - "! a. fmul 0 a = 0"
20.1269 - "! a. fmul a 0 = 0"
20.1270 - "fadd 0 0 = 0"
20.1271 - shows
20.1272 - "Rep_matrix(mult_matrix fmul fadd A B) j i =
20.1273 - foldseq fadd (% k. fmul (Rep_matrix A j k) (Rep_matrix B k i)) (max (ncols A) (nrows B))"
20.1274 -apply (simp add: mult_matrix_def mult_matrix_n_def)
20.1275 -apply (subst RepAbs_matrix)
20.1276 -apply (rule exI[of _ "nrows A"], insert assms, simp add: nrows foldseq_zero)
20.1277 -apply (rule exI[of _ "ncols B"], insert assms, simp add: ncols foldseq_zero)
20.1278 -apply simp
20.1279 -done
20.1280 -
20.1281 -lemma transpose_mult_matrix:
20.1282 - assumes
20.1283 - "! a. fmul 0 a = 0"
20.1284 - "! a. fmul a 0 = 0"
20.1285 - "fadd 0 0 = 0"
20.1286 - "! x y. fmul y x = fmul x y"
20.1287 - shows
20.1288 - "transpose_matrix (mult_matrix fmul fadd A B) = mult_matrix fmul fadd (transpose_matrix B) (transpose_matrix A)"
20.1289 - apply (simp add: Rep_matrix_inject[THEN sym])
20.1290 - apply (rule ext)+
20.1291 - using assms
20.1292 - apply (simp add: Rep_mult_matrix max_ac)
20.1293 - done
20.1294 -
20.1295 -lemma column_transpose_matrix: "column_of_matrix (transpose_matrix A) n = transpose_matrix (row_of_matrix A n)"
20.1296 -apply (simp add: Rep_matrix_inject[THEN sym])
20.1297 -apply (rule ext)+
20.1298 -by simp
20.1299 -
20.1300 -lemma take_columns_transpose_matrix: "take_columns (transpose_matrix A) n = transpose_matrix (take_rows A n)"
20.1301 -apply (simp add: Rep_matrix_inject[THEN sym])
20.1302 -apply (rule ext)+
20.1303 -by simp
20.1304 -
20.1305 -instantiation matrix :: ("{zero, ord}") ord
20.1306 -begin
20.1307 -
20.1308 -definition
20.1309 - le_matrix_def: "A \<le> B \<longleftrightarrow> (\<forall>j i. Rep_matrix A j i \<le> Rep_matrix B j i)"
20.1310 -
20.1311 -definition
20.1312 - less_def: "A < (B\<Colon>'a matrix) \<longleftrightarrow> A \<le> B \<and> \<not> B \<le> A"
20.1313 -
20.1314 -instance ..
20.1315 -
20.1316 -end
20.1317 -
20.1318 -instance matrix :: ("{zero, order}") order
20.1319 -apply intro_classes
20.1320 -apply (simp_all add: le_matrix_def less_def)
20.1321 -apply (auto)
20.1322 -apply (drule_tac x=j in spec, drule_tac x=j in spec)
20.1323 -apply (drule_tac x=i in spec, drule_tac x=i in spec)
20.1324 -apply (simp)
20.1325 -apply (simp add: Rep_matrix_inject[THEN sym])
20.1326 -apply (rule ext)+
20.1327 -apply (drule_tac x=xa in spec, drule_tac x=xa in spec)
20.1328 -apply (drule_tac x=xb in spec, drule_tac x=xb in spec)
20.1329 -apply simp
20.1330 -done
20.1331 -
20.1332 -lemma le_apply_matrix:
20.1333 - assumes
20.1334 - "f 0 = 0"
20.1335 - "! x y. x <= y \<longrightarrow> f x <= f y"
20.1336 - "(a::('a::{ord, zero}) matrix) <= b"
20.1337 - shows
20.1338 - "apply_matrix f a <= apply_matrix f b"
20.1339 - using assms by (simp add: le_matrix_def)
20.1340 -
20.1341 -lemma le_combine_matrix:
20.1342 - assumes
20.1343 - "f 0 0 = 0"
20.1344 - "! a b c d. a <= b & c <= d \<longrightarrow> f a c <= f b d"
20.1345 - "A <= B"
20.1346 - "C <= D"
20.1347 - shows
20.1348 - "combine_matrix f A C <= combine_matrix f B D"
20.1349 - using assms by (simp add: le_matrix_def)
20.1350 -
20.1351 -lemma le_left_combine_matrix:
20.1352 - assumes
20.1353 - "f 0 0 = 0"
20.1354 - "! a b c. a <= b \<longrightarrow> f c a <= f c b"
20.1355 - "A <= B"
20.1356 - shows
20.1357 - "combine_matrix f C A <= combine_matrix f C B"
20.1358 - using assms by (simp add: le_matrix_def)
20.1359 -
20.1360 -lemma le_right_combine_matrix:
20.1361 - assumes
20.1362 - "f 0 0 = 0"
20.1363 - "! a b c. a <= b \<longrightarrow> f a c <= f b c"
20.1364 - "A <= B"
20.1365 - shows
20.1366 - "combine_matrix f A C <= combine_matrix f B C"
20.1367 - using assms by (simp add: le_matrix_def)
20.1368 -
20.1369 -lemma le_transpose_matrix: "(A <= B) = (transpose_matrix A <= transpose_matrix B)"
20.1370 - by (simp add: le_matrix_def, auto)
20.1371 -
20.1372 -lemma le_foldseq:
20.1373 - assumes
20.1374 - "! a b c d . a <= b & c <= d \<longrightarrow> f a c <= f b d"
20.1375 - "! i. i <= n \<longrightarrow> s i <= t i"
20.1376 - shows
20.1377 - "foldseq f s n <= foldseq f t n"
20.1378 -proof -
20.1379 - have "! s t. (! i. i<=n \<longrightarrow> s i <= t i) \<longrightarrow> foldseq f s n <= foldseq f t n"
20.1380 - by (induct n) (simp_all add: assms)
20.1381 - then show "foldseq f s n <= foldseq f t n" using assms by simp
20.1382 -qed
20.1383 -
20.1384 -lemma le_left_mult:
20.1385 - assumes
20.1386 - "! a b c d. a <= b & c <= d \<longrightarrow> fadd a c <= fadd b d"
20.1387 - "! c a b. 0 <= c & a <= b \<longrightarrow> fmul c a <= fmul c b"
20.1388 - "! a. fmul 0 a = 0"
20.1389 - "! a. fmul a 0 = 0"
20.1390 - "fadd 0 0 = 0"
20.1391 - "0 <= C"
20.1392 - "A <= B"
20.1393 - shows
20.1394 - "mult_matrix fmul fadd C A <= mult_matrix fmul fadd C B"
20.1395 - using assms
20.1396 - apply (simp add: le_matrix_def Rep_mult_matrix)
20.1397 - apply (auto)
20.1398 - apply (simplesubst foldseq_zerotail[of _ _ _ "max (ncols C) (max (nrows A) (nrows B))"], simp_all add: nrows ncols max1 max2)+
20.1399 - apply (rule le_foldseq)
20.1400 - apply (auto)
20.1401 - done
20.1402 -
20.1403 -lemma le_right_mult:
20.1404 - assumes
20.1405 - "! a b c d. a <= b & c <= d \<longrightarrow> fadd a c <= fadd b d"
20.1406 - "! c a b. 0 <= c & a <= b \<longrightarrow> fmul a c <= fmul b c"
20.1407 - "! a. fmul 0 a = 0"
20.1408 - "! a. fmul a 0 = 0"
20.1409 - "fadd 0 0 = 0"
20.1410 - "0 <= C"
20.1411 - "A <= B"
20.1412 - shows
20.1413 - "mult_matrix fmul fadd A C <= mult_matrix fmul fadd B C"
20.1414 - using assms
20.1415 - apply (simp add: le_matrix_def Rep_mult_matrix)
20.1416 - apply (auto)
20.1417 - apply (simplesubst foldseq_zerotail[of _ _ _ "max (nrows C) (max (ncols A) (ncols B))"], simp_all add: nrows ncols max1 max2)+
20.1418 - apply (rule le_foldseq)
20.1419 - apply (auto)
20.1420 - done
20.1421 -
20.1422 -lemma spec2: "! j i. P j i \<Longrightarrow> P j i" by blast
20.1423 -lemma neg_imp: "(\<not> Q \<longrightarrow> \<not> P) \<Longrightarrow> P \<longrightarrow> Q" by blast
20.1424 -
20.1425 -lemma singleton_matrix_le[simp]: "(singleton_matrix j i a <= singleton_matrix j i b) = (a <= (b::_::order))"
20.1426 - by (auto simp add: le_matrix_def)
20.1427 -
20.1428 -lemma singleton_le_zero[simp]: "(singleton_matrix j i x <= 0) = (x <= (0::'a::{order,zero}))"
20.1429 - apply (auto)
20.1430 - apply (simp add: le_matrix_def)
20.1431 - apply (drule_tac j=j and i=i in spec2)
20.1432 - apply (simp)
20.1433 - apply (simp add: le_matrix_def)
20.1434 - done
20.1435 -
20.1436 -lemma singleton_ge_zero[simp]: "(0 <= singleton_matrix j i x) = ((0::'a::{order,zero}) <= x)"
20.1437 - apply (auto)
20.1438 - apply (simp add: le_matrix_def)
20.1439 - apply (drule_tac j=j and i=i in spec2)
20.1440 - apply (simp)
20.1441 - apply (simp add: le_matrix_def)
20.1442 - done
20.1443 -
20.1444 -lemma move_matrix_le_zero[simp]: "0 <= j \<Longrightarrow> 0 <= i \<Longrightarrow> (move_matrix A j i <= 0) = (A <= (0::('a::{order,zero}) matrix))"
20.1445 - apply (auto simp add: le_matrix_def)
20.1446 - apply (drule_tac j="ja+(nat j)" and i="ia+(nat i)" in spec2)
20.1447 - apply (auto)
20.1448 - done
20.1449 -
20.1450 -lemma move_matrix_zero_le[simp]: "0 <= j \<Longrightarrow> 0 <= i \<Longrightarrow> (0 <= move_matrix A j i) = ((0::('a::{order,zero}) matrix) <= A)"
20.1451 - apply (auto simp add: le_matrix_def)
20.1452 - apply (drule_tac j="ja+(nat j)" and i="ia+(nat i)" in spec2)
20.1453 - apply (auto)
20.1454 - done
20.1455 -
20.1456 -lemma move_matrix_le_move_matrix_iff[simp]: "0 <= j \<Longrightarrow> 0 <= i \<Longrightarrow> (move_matrix A j i <= move_matrix B j i) = (A <= (B::('a::{order,zero}) matrix))"
20.1457 - apply (auto simp add: le_matrix_def)
20.1458 - apply (drule_tac j="ja+(nat j)" and i="ia+(nat i)" in spec2)
20.1459 - apply (auto)
20.1460 - done
20.1461 -
20.1462 -instantiation matrix :: ("{lattice, zero}") lattice
20.1463 -begin
20.1464 -
20.1465 -definition "inf = combine_matrix inf"
20.1466 -
20.1467 -definition "sup = combine_matrix sup"
20.1468 -
20.1469 -instance
20.1470 - by default (auto simp add: le_infI le_matrix_def inf_matrix_def sup_matrix_def)
20.1471 -
20.1472 -end
20.1473 -
20.1474 -instantiation matrix :: ("{plus, zero}") plus
20.1475 -begin
20.1476 -
20.1477 -definition
20.1478 - plus_matrix_def: "A + B = combine_matrix (op +) A B"
20.1479 -
20.1480 -instance ..
20.1481 -
20.1482 -end
20.1483 -
20.1484 -instantiation matrix :: ("{uminus, zero}") uminus
20.1485 -begin
20.1486 -
20.1487 -definition
20.1488 - minus_matrix_def: "- A = apply_matrix uminus A"
20.1489 -
20.1490 -instance ..
20.1491 -
20.1492 -end
20.1493 -
20.1494 -instantiation matrix :: ("{minus, zero}") minus
20.1495 -begin
20.1496 -
20.1497 -definition
20.1498 - diff_matrix_def: "A - B = combine_matrix (op -) A B"
20.1499 -
20.1500 -instance ..
20.1501 -
20.1502 -end
20.1503 -
20.1504 -instantiation matrix :: ("{plus, times, zero}") times
20.1505 -begin
20.1506 -
20.1507 -definition
20.1508 - times_matrix_def: "A * B = mult_matrix (op *) (op +) A B"
20.1509 -
20.1510 -instance ..
20.1511 -
20.1512 -end
20.1513 -
20.1514 -instantiation matrix :: ("{lattice, uminus, zero}") abs
20.1515 -begin
20.1516 -
20.1517 -definition
20.1518 - abs_matrix_def: "abs (A \<Colon> 'a matrix) = sup A (- A)"
20.1519 -
20.1520 -instance ..
20.1521 -
20.1522 -end
20.1523 -
20.1524 -instance matrix :: (monoid_add) monoid_add
20.1525 -proof
20.1526 - fix A B C :: "'a matrix"
20.1527 - show "A + B + C = A + (B + C)"
20.1528 - apply (simp add: plus_matrix_def)
20.1529 - apply (rule combine_matrix_assoc[simplified associative_def, THEN spec, THEN spec, THEN spec])
20.1530 - apply (simp_all add: add_assoc)
20.1531 - done
20.1532 - show "0 + A = A"
20.1533 - apply (simp add: plus_matrix_def)
20.1534 - apply (rule combine_matrix_zero_l_neutral[simplified zero_l_neutral_def, THEN spec])
20.1535 - apply (simp)
20.1536 - done
20.1537 - show "A + 0 = A"
20.1538 - apply (simp add: plus_matrix_def)
20.1539 - apply (rule combine_matrix_zero_r_neutral [simplified zero_r_neutral_def, THEN spec])
20.1540 - apply (simp)
20.1541 - done
20.1542 -qed
20.1543 -
20.1544 -instance matrix :: (comm_monoid_add) comm_monoid_add
20.1545 -proof
20.1546 - fix A B :: "'a matrix"
20.1547 - show "A + B = B + A"
20.1548 - apply (simp add: plus_matrix_def)
20.1549 - apply (rule combine_matrix_commute[simplified commutative_def, THEN spec, THEN spec])
20.1550 - apply (simp_all add: add_commute)
20.1551 - done
20.1552 - show "0 + A = A"
20.1553 - apply (simp add: plus_matrix_def)
20.1554 - apply (rule combine_matrix_zero_l_neutral[simplified zero_l_neutral_def, THEN spec])
20.1555 - apply (simp)
20.1556 - done
20.1557 -qed
20.1558 -
20.1559 -instance matrix :: (group_add) group_add
20.1560 -proof
20.1561 - fix A B :: "'a matrix"
20.1562 - show "- A + A = 0"
20.1563 - by (simp add: plus_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
20.1564 - show "A - B = A + - B"
20.1565 - by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject [symmetric] ext diff_minus)
20.1566 -qed
20.1567 -
20.1568 -instance matrix :: (ab_group_add) ab_group_add
20.1569 -proof
20.1570 - fix A B :: "'a matrix"
20.1571 - show "- A + A = 0"
20.1572 - by (simp add: plus_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
20.1573 - show "A - B = A + - B"
20.1574 - by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
20.1575 -qed
20.1576 -
20.1577 -instance matrix :: (ordered_ab_group_add) ordered_ab_group_add
20.1578 -proof
20.1579 - fix A B C :: "'a matrix"
20.1580 - assume "A <= B"
20.1581 - then show "C + A <= C + B"
20.1582 - apply (simp add: plus_matrix_def)
20.1583 - apply (rule le_left_combine_matrix)
20.1584 - apply (simp_all)
20.1585 - done
20.1586 -qed
20.1587 -
20.1588 -instance matrix :: (lattice_ab_group_add) semilattice_inf_ab_group_add ..
20.1589 -instance matrix :: (lattice_ab_group_add) semilattice_sup_ab_group_add ..
20.1590 -
20.1591 -instance matrix :: (semiring_0) semiring_0
20.1592 -proof
20.1593 - fix A B C :: "'a matrix"
20.1594 - show "A * B * C = A * (B * C)"
20.1595 - apply (simp add: times_matrix_def)
20.1596 - apply (rule mult_matrix_assoc)
20.1597 - apply (simp_all add: associative_def algebra_simps)
20.1598 - done
20.1599 - show "(A + B) * C = A * C + B * C"
20.1600 - apply (simp add: times_matrix_def plus_matrix_def)
20.1601 - apply (rule l_distributive_matrix[simplified l_distributive_def, THEN spec, THEN spec, THEN spec])
20.1602 - apply (simp_all add: associative_def commutative_def algebra_simps)
20.1603 - done
20.1604 - show "A * (B + C) = A * B + A * C"
20.1605 - apply (simp add: times_matrix_def plus_matrix_def)
20.1606 - apply (rule r_distributive_matrix[simplified r_distributive_def, THEN spec, THEN spec, THEN spec])
20.1607 - apply (simp_all add: associative_def commutative_def algebra_simps)
20.1608 - done
20.1609 - show "0 * A = 0" by (simp add: times_matrix_def)
20.1610 - show "A * 0 = 0" by (simp add: times_matrix_def)
20.1611 -qed
20.1612 -
20.1613 -instance matrix :: (ring) ring ..
20.1614 -
20.1615 -instance matrix :: (ordered_ring) ordered_ring
20.1616 -proof
20.1617 - fix A B C :: "'a matrix"
20.1618 - assume a: "A \<le> B"
20.1619 - assume b: "0 \<le> C"
20.1620 - from a b show "C * A \<le> C * B"
20.1621 - apply (simp add: times_matrix_def)
20.1622 - apply (rule le_left_mult)
20.1623 - apply (simp_all add: add_mono mult_left_mono)
20.1624 - done
20.1625 - from a b show "A * C \<le> B * C"
20.1626 - apply (simp add: times_matrix_def)
20.1627 - apply (rule le_right_mult)
20.1628 - apply (simp_all add: add_mono mult_right_mono)
20.1629 - done
20.1630 -qed
20.1631 -
20.1632 -instance matrix :: (lattice_ring) lattice_ring
20.1633 -proof
20.1634 - fix A B C :: "('a :: lattice_ring) matrix"
20.1635 - show "abs A = sup A (-A)"
20.1636 - by (simp add: abs_matrix_def)
20.1637 -qed
20.1638 -
20.1639 -lemma Rep_matrix_add[simp]:
20.1640 - "Rep_matrix ((a::('a::monoid_add)matrix)+b) j i = (Rep_matrix a j i) + (Rep_matrix b j i)"
20.1641 - by (simp add: plus_matrix_def)
20.1642 -
20.1643 -lemma Rep_matrix_mult: "Rep_matrix ((a::('a::semiring_0) matrix) * b) j i =
20.1644 - foldseq (op +) (% k. (Rep_matrix a j k) * (Rep_matrix b k i)) (max (ncols a) (nrows b))"
20.1645 -apply (simp add: times_matrix_def)
20.1646 -apply (simp add: Rep_mult_matrix)
20.1647 -done
20.1648 -
20.1649 -lemma apply_matrix_add: "! x y. f (x+y) = (f x) + (f y) \<Longrightarrow> f 0 = (0::'a)
20.1650 - \<Longrightarrow> apply_matrix f ((a::('a::monoid_add) matrix) + b) = (apply_matrix f a) + (apply_matrix f b)"
20.1651 -apply (subst Rep_matrix_inject[symmetric])
20.1652 -apply (rule ext)+
20.1653 -apply (simp)
20.1654 -done
20.1655 -
20.1656 -lemma singleton_matrix_add: "singleton_matrix j i ((a::_::monoid_add)+b) = (singleton_matrix j i a) + (singleton_matrix j i b)"
20.1657 -apply (subst Rep_matrix_inject[symmetric])
20.1658 -apply (rule ext)+
20.1659 -apply (simp)
20.1660 -done
20.1661 -
20.1662 -lemma nrows_mult: "nrows ((A::('a::semiring_0) matrix) * B) <= nrows A"
20.1663 -by (simp add: times_matrix_def mult_nrows)
20.1664 -
20.1665 -lemma ncols_mult: "ncols ((A::('a::semiring_0) matrix) * B) <= ncols B"
20.1666 -by (simp add: times_matrix_def mult_ncols)
20.1667 -
20.1668 -definition
20.1669 - one_matrix :: "nat \<Rightarrow> ('a::{zero,one}) matrix" where
20.1670 - "one_matrix n = Abs_matrix (% j i. if j = i & j < n then 1 else 0)"
20.1671 -
20.1672 -lemma Rep_one_matrix[simp]: "Rep_matrix (one_matrix n) j i = (if (j = i & j < n) then 1 else 0)"
20.1673 -apply (simp add: one_matrix_def)
20.1674 -apply (simplesubst RepAbs_matrix)
20.1675 -apply (rule exI[of _ n], simp add: split_if)+
20.1676 -by (simp add: split_if)
20.1677 -
20.1678 -lemma nrows_one_matrix[simp]: "nrows ((one_matrix n) :: ('a::zero_neq_one)matrix) = n" (is "?r = _")
20.1679 -proof -
20.1680 - have "?r <= n" by (simp add: nrows_le)
20.1681 - moreover have "n <= ?r" by (simp add:le_nrows, arith)
20.1682 - ultimately show "?r = n" by simp
20.1683 -qed
20.1684 -
20.1685 -lemma ncols_one_matrix[simp]: "ncols ((one_matrix n) :: ('a::zero_neq_one)matrix) = n" (is "?r = _")
20.1686 -proof -
20.1687 - have "?r <= n" by (simp add: ncols_le)
20.1688 - moreover have "n <= ?r" by (simp add: le_ncols, arith)
20.1689 - ultimately show "?r = n" by simp
20.1690 -qed
20.1691 -
20.1692 -lemma one_matrix_mult_right[simp]: "ncols A <= n \<Longrightarrow> (A::('a::{semiring_1}) matrix) * (one_matrix n) = A"
20.1693 -apply (subst Rep_matrix_inject[THEN sym])
20.1694 -apply (rule ext)+
20.1695 -apply (simp add: times_matrix_def Rep_mult_matrix)
20.1696 -apply (rule_tac j1="xa" in ssubst[OF foldseq_almostzero])
20.1697 -apply (simp_all)
20.1698 -by (simp add: ncols)
20.1699 -
20.1700 -lemma one_matrix_mult_left[simp]: "nrows A <= n \<Longrightarrow> (one_matrix n) * A = (A::('a::semiring_1) matrix)"
20.1701 -apply (subst Rep_matrix_inject[THEN sym])
20.1702 -apply (rule ext)+
20.1703 -apply (simp add: times_matrix_def Rep_mult_matrix)
20.1704 -apply (rule_tac j1="x" in ssubst[OF foldseq_almostzero])
20.1705 -apply (simp_all)
20.1706 -by (simp add: nrows)
20.1707 -
20.1708 -lemma transpose_matrix_mult: "transpose_matrix ((A::('a::comm_ring) matrix)*B) = (transpose_matrix B) * (transpose_matrix A)"
20.1709 -apply (simp add: times_matrix_def)
20.1710 -apply (subst transpose_mult_matrix)
20.1711 -apply (simp_all add: mult_commute)
20.1712 -done
20.1713 -
20.1714 -lemma transpose_matrix_add: "transpose_matrix ((A::('a::monoid_add) matrix)+B) = transpose_matrix A + transpose_matrix B"
20.1715 -by (simp add: plus_matrix_def transpose_combine_matrix)
20.1716 -
20.1717 -lemma transpose_matrix_diff: "transpose_matrix ((A::('a::group_add) matrix)-B) = transpose_matrix A - transpose_matrix B"
20.1718 -by (simp add: diff_matrix_def transpose_combine_matrix)
20.1719 -
20.1720 -lemma transpose_matrix_minus: "transpose_matrix (-(A::('a::group_add) matrix)) = - transpose_matrix (A::'a matrix)"
20.1721 -by (simp add: minus_matrix_def transpose_apply_matrix)
20.1722 -
20.1723 -definition right_inverse_matrix :: "('a::{ring_1}) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
20.1724 - "right_inverse_matrix A X == (A * X = one_matrix (max (nrows A) (ncols X))) \<and> nrows X \<le> ncols A"
20.1725 -
20.1726 -definition left_inverse_matrix :: "('a::{ring_1}) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
20.1727 - "left_inverse_matrix A X == (X * A = one_matrix (max(nrows X) (ncols A))) \<and> ncols X \<le> nrows A"
20.1728 -
20.1729 -definition inverse_matrix :: "('a::{ring_1}) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
20.1730 - "inverse_matrix A X == (right_inverse_matrix A X) \<and> (left_inverse_matrix A X)"
20.1731 -
20.1732 -lemma right_inverse_matrix_dim: "right_inverse_matrix A X \<Longrightarrow> nrows A = ncols X"
20.1733 -apply (insert ncols_mult[of A X], insert nrows_mult[of A X])
20.1734 -by (simp add: right_inverse_matrix_def)
20.1735 -
20.1736 -lemma left_inverse_matrix_dim: "left_inverse_matrix A Y \<Longrightarrow> ncols A = nrows Y"
20.1737 -apply (insert ncols_mult[of Y A], insert nrows_mult[of Y A])
20.1738 -by (simp add: left_inverse_matrix_def)
20.1739 -
20.1740 -lemma left_right_inverse_matrix_unique:
20.1741 - assumes "left_inverse_matrix A Y" "right_inverse_matrix A X"
20.1742 - shows "X = Y"
20.1743 -proof -
20.1744 - have "Y = Y * one_matrix (nrows A)"
20.1745 - apply (subst one_matrix_mult_right)
20.1746 - using assms
20.1747 - apply (simp_all add: left_inverse_matrix_def)
20.1748 - done
20.1749 - also have "\<dots> = Y * (A * X)"
20.1750 - apply (insert assms)
20.1751 - apply (frule right_inverse_matrix_dim)
20.1752 - by (simp add: right_inverse_matrix_def)
20.1753 - also have "\<dots> = (Y * A) * X" by (simp add: mult_assoc)
20.1754 - also have "\<dots> = X"
20.1755 - apply (insert assms)
20.1756 - apply (frule left_inverse_matrix_dim)
20.1757 - apply (simp_all add: left_inverse_matrix_def right_inverse_matrix_def one_matrix_mult_left)
20.1758 - done
20.1759 - ultimately show "X = Y" by (simp)
20.1760 -qed
20.1761 -
20.1762 -lemma inverse_matrix_inject: "\<lbrakk> inverse_matrix A X; inverse_matrix A Y \<rbrakk> \<Longrightarrow> X = Y"
20.1763 - by (auto simp add: inverse_matrix_def left_right_inverse_matrix_unique)
20.1764 -
20.1765 -lemma one_matrix_inverse: "inverse_matrix (one_matrix n) (one_matrix n)"
20.1766 - by (simp add: inverse_matrix_def left_inverse_matrix_def right_inverse_matrix_def)
20.1767 -
20.1768 -lemma zero_imp_mult_zero: "(a::'a::semiring_0) = 0 | b = 0 \<Longrightarrow> a * b = 0"
20.1769 -by auto
20.1770 -
20.1771 -lemma Rep_matrix_zero_imp_mult_zero:
20.1772 - "! j i k. (Rep_matrix A j k = 0) | (Rep_matrix B k i) = 0 \<Longrightarrow> A * B = (0::('a::lattice_ring) matrix)"
20.1773 -apply (subst Rep_matrix_inject[symmetric])
20.1774 -apply (rule ext)+
20.1775 -apply (auto simp add: Rep_matrix_mult foldseq_zero zero_imp_mult_zero)
20.1776 -done
20.1777 -
20.1778 -lemma add_nrows: "nrows (A::('a::monoid_add) matrix) <= u \<Longrightarrow> nrows B <= u \<Longrightarrow> nrows (A + B) <= u"
20.1779 -apply (simp add: plus_matrix_def)
20.1780 -apply (rule combine_nrows)
20.1781 -apply (simp_all)
20.1782 -done
20.1783 -
20.1784 -lemma move_matrix_row_mult: "move_matrix ((A::('a::semiring_0) matrix) * B) j 0 = (move_matrix A j 0) * B"
20.1785 -apply (subst Rep_matrix_inject[symmetric])
20.1786 -apply (rule ext)+
20.1787 -apply (auto simp add: Rep_matrix_mult foldseq_zero)
20.1788 -apply (rule_tac foldseq_zerotail[symmetric])
20.1789 -apply (auto simp add: nrows zero_imp_mult_zero max2)
20.1790 -apply (rule order_trans)
20.1791 -apply (rule ncols_move_matrix_le)
20.1792 -apply (simp add: max1)
20.1793 -done
20.1794 -
20.1795 -lemma move_matrix_col_mult: "move_matrix ((A::('a::semiring_0) matrix) * B) 0 i = A * (move_matrix B 0 i)"
20.1796 -apply (subst Rep_matrix_inject[symmetric])
20.1797 -apply (rule ext)+
20.1798 -apply (auto simp add: Rep_matrix_mult foldseq_zero)
20.1799 -apply (rule_tac foldseq_zerotail[symmetric])
20.1800 -apply (auto simp add: ncols zero_imp_mult_zero max1)
20.1801 -apply (rule order_trans)
20.1802 -apply (rule nrows_move_matrix_le)
20.1803 -apply (simp add: max2)
20.1804 -done
20.1805 -
20.1806 -lemma move_matrix_add: "((move_matrix (A + B) j i)::(('a::monoid_add) matrix)) = (move_matrix A j i) + (move_matrix B j i)"
20.1807 -apply (subst Rep_matrix_inject[symmetric])
20.1808 -apply (rule ext)+
20.1809 -apply (simp)
20.1810 -done
20.1811 -
20.1812 -lemma move_matrix_mult: "move_matrix ((A::('a::semiring_0) matrix)*B) j i = (move_matrix A j 0) * (move_matrix B 0 i)"
20.1813 -by (simp add: move_matrix_ortho[of "A*B"] move_matrix_col_mult move_matrix_row_mult)
20.1814 -
20.1815 -definition scalar_mult :: "('a::ring) \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" where
20.1816 - "scalar_mult a m == apply_matrix (op * a) m"
20.1817 -
20.1818 -lemma scalar_mult_zero[simp]: "scalar_mult y 0 = 0"
20.1819 -by (simp add: scalar_mult_def)
20.1820 -
20.1821 -lemma scalar_mult_add: "scalar_mult y (a+b) = (scalar_mult y a) + (scalar_mult y b)"
20.1822 -by (simp add: scalar_mult_def apply_matrix_add algebra_simps)
20.1823 -
20.1824 -lemma Rep_scalar_mult[simp]: "Rep_matrix (scalar_mult y a) j i = y * (Rep_matrix a j i)"
20.1825 -by (simp add: scalar_mult_def)
20.1826 -
20.1827 -lemma scalar_mult_singleton[simp]: "scalar_mult y (singleton_matrix j i x) = singleton_matrix j i (y * x)"
20.1828 -apply (subst Rep_matrix_inject[symmetric])
20.1829 -apply (rule ext)+
20.1830 -apply (auto)
20.1831 -done
20.1832 -
20.1833 -lemma Rep_minus[simp]: "Rep_matrix (-(A::_::group_add)) x y = - (Rep_matrix A x y)"
20.1834 -by (simp add: minus_matrix_def)
20.1835 -
20.1836 -lemma Rep_abs[simp]: "Rep_matrix (abs (A::_::lattice_ab_group_add)) x y = abs (Rep_matrix A x y)"
20.1837 -by (simp add: abs_lattice sup_matrix_def)
20.1838 -
20.1839 -end
21.1 --- a/src/HOL/Matrix/ROOT.ML Sat Mar 17 12:26:19 2012 +0100
21.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3 @@ -1,2 +0,0 @@
21.4 -
21.5 -use_thy "Cplex";
22.1 --- a/src/HOL/Matrix/SparseMatrix.thy Sat Mar 17 12:26:19 2012 +0100
22.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3 @@ -1,1070 +0,0 @@
22.4 -(* Title: HOL/Matrix/SparseMatrix.thy
22.5 - Author: Steven Obua
22.6 -*)
22.7 -
22.8 -theory SparseMatrix
22.9 -imports Matrix
22.10 -begin
22.11 -
22.12 -type_synonym 'a spvec = "(nat * 'a) list"
22.13 -type_synonym 'a spmat = "'a spvec spvec"
22.14 -
22.15 -definition sparse_row_vector :: "('a::ab_group_add) spvec \<Rightarrow> 'a matrix"
22.16 - where "sparse_row_vector arr = foldl (% m x. m + (singleton_matrix 0 (fst x) (snd x))) 0 arr"
22.17 -
22.18 -definition sparse_row_matrix :: "('a::ab_group_add) spmat \<Rightarrow> 'a matrix"
22.19 - where "sparse_row_matrix arr = foldl (% m r. m + (move_matrix (sparse_row_vector (snd r)) (int (fst r)) 0)) 0 arr"
22.20 -
22.21 -code_datatype sparse_row_vector sparse_row_matrix
22.22 -
22.23 -lemma sparse_row_vector_empty [simp]: "sparse_row_vector [] = 0"
22.24 - by (simp add: sparse_row_vector_def)
22.25 -
22.26 -lemma sparse_row_matrix_empty [simp]: "sparse_row_matrix [] = 0"
22.27 - by (simp add: sparse_row_matrix_def)
22.28 -
22.29 -lemmas [code] = sparse_row_vector_empty [symmetric]
22.30 -
22.31 -lemma foldl_distrstart: "! a x y. (f (g x y) a = g x (f y a)) \<Longrightarrow> (foldl f (g x y) l = g x (foldl f y l))"
22.32 - by (induct l arbitrary: x y, auto)
22.33 -
22.34 -lemma sparse_row_vector_cons[simp]:
22.35 - "sparse_row_vector (a # arr) = (singleton_matrix 0 (fst a) (snd a)) + (sparse_row_vector arr)"
22.36 - apply (induct arr)
22.37 - apply (auto simp add: sparse_row_vector_def)
22.38 - apply (simp add: foldl_distrstart [of "\<lambda>m x. m + singleton_matrix 0 (fst x) (snd x)" "\<lambda>x m. singleton_matrix 0 (fst x) (snd x) + m"])
22.39 - done
22.40 -
22.41 -lemma sparse_row_vector_append[simp]:
22.42 - "sparse_row_vector (a @ b) = (sparse_row_vector a) + (sparse_row_vector b)"
22.43 - by (induct a) auto
22.44 -
22.45 -lemma nrows_spvec[simp]: "nrows (sparse_row_vector x) <= (Suc 0)"
22.46 - apply (induct x)
22.47 - apply (simp_all add: add_nrows)
22.48 - done
22.49 -
22.50 -lemma sparse_row_matrix_cons: "sparse_row_matrix (a#arr) = ((move_matrix (sparse_row_vector (snd a)) (int (fst a)) 0)) + sparse_row_matrix arr"
22.51 - apply (induct arr)
22.52 - apply (auto simp add: sparse_row_matrix_def)
22.53 - apply (simp add: foldl_distrstart[of "\<lambda>m x. m + (move_matrix (sparse_row_vector (snd x)) (int (fst x)) 0)"
22.54 - "% a m. (move_matrix (sparse_row_vector (snd a)) (int (fst a)) 0) + m"])
22.55 - done
22.56 -
22.57 -lemma sparse_row_matrix_append: "sparse_row_matrix (arr@brr) = (sparse_row_matrix arr) + (sparse_row_matrix brr)"
22.58 - apply (induct arr)
22.59 - apply (auto simp add: sparse_row_matrix_cons)
22.60 - done
22.61 -
22.62 -primrec sorted_spvec :: "'a spvec \<Rightarrow> bool"
22.63 -where
22.64 - "sorted_spvec [] = True"
22.65 -| sorted_spvec_step: "sorted_spvec (a#as) = (case as of [] \<Rightarrow> True | b#bs \<Rightarrow> ((fst a < fst b) & (sorted_spvec as)))"
22.66 -
22.67 -primrec sorted_spmat :: "'a spmat \<Rightarrow> bool"
22.68 -where
22.69 - "sorted_spmat [] = True"
22.70 -| "sorted_spmat (a#as) = ((sorted_spvec (snd a)) & (sorted_spmat as))"
22.71 -
22.72 -declare sorted_spvec.simps [simp del]
22.73 -
22.74 -lemma sorted_spvec_empty[simp]: "sorted_spvec [] = True"
22.75 -by (simp add: sorted_spvec.simps)
22.76 -
22.77 -lemma sorted_spvec_cons1: "sorted_spvec (a#as) \<Longrightarrow> sorted_spvec as"
22.78 -apply (induct as)
22.79 -apply (auto simp add: sorted_spvec.simps)
22.80 -done
22.81 -
22.82 -lemma sorted_spvec_cons2: "sorted_spvec (a#b#t) \<Longrightarrow> sorted_spvec (a#t)"
22.83 -apply (induct t)
22.84 -apply (auto simp add: sorted_spvec.simps)
22.85 -done
22.86 -
22.87 -lemma sorted_spvec_cons3: "sorted_spvec(a#b#t) \<Longrightarrow> fst a < fst b"
22.88 -apply (auto simp add: sorted_spvec.simps)
22.89 -done
22.90 -
22.91 -lemma sorted_sparse_row_vector_zero[rule_format]: "m <= n \<Longrightarrow> sorted_spvec ((n,a)#arr) \<longrightarrow> Rep_matrix (sparse_row_vector arr) j m = 0"
22.92 -apply (induct arr)
22.93 -apply (auto)
22.94 -apply (frule sorted_spvec_cons2,simp)+
22.95 -apply (frule sorted_spvec_cons3, simp)
22.96 -done
22.97 -
22.98 -lemma sorted_sparse_row_matrix_zero[rule_format]: "m <= n \<Longrightarrow> sorted_spvec ((n,a)#arr) \<longrightarrow> Rep_matrix (sparse_row_matrix arr) m j = 0"
22.99 - apply (induct arr)
22.100 - apply (auto)
22.101 - apply (frule sorted_spvec_cons2, simp)
22.102 - apply (frule sorted_spvec_cons3, simp)
22.103 - apply (simp add: sparse_row_matrix_cons)
22.104 - done
22.105 -
22.106 -primrec minus_spvec :: "('a::ab_group_add) spvec \<Rightarrow> 'a spvec"
22.107 -where
22.108 - "minus_spvec [] = []"
22.109 -| "minus_spvec (a#as) = (fst a, -(snd a))#(minus_spvec as)"
22.110 -
22.111 -primrec abs_spvec :: "('a::lattice_ab_group_add_abs) spvec \<Rightarrow> 'a spvec"
22.112 -where
22.113 - "abs_spvec [] = []"
22.114 -| "abs_spvec (a#as) = (fst a, abs (snd a))#(abs_spvec as)"
22.115 -
22.116 -lemma sparse_row_vector_minus:
22.117 - "sparse_row_vector (minus_spvec v) = - (sparse_row_vector v)"
22.118 - apply (induct v)
22.119 - apply (simp_all add: sparse_row_vector_cons)
22.120 - apply (simp add: Rep_matrix_inject[symmetric])
22.121 - apply (rule ext)+
22.122 - apply simp
22.123 - done
22.124 -
22.125 -instance matrix :: (lattice_ab_group_add_abs) lattice_ab_group_add_abs
22.126 -apply default
22.127 -unfolding abs_matrix_def .. (*FIXME move*)
22.128 -
22.129 -lemma sparse_row_vector_abs:
22.130 - "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (abs_spvec v) = abs (sparse_row_vector v)"
22.131 - apply (induct v)
22.132 - apply simp_all
22.133 - apply (frule_tac sorted_spvec_cons1, simp)
22.134 - apply (simp only: Rep_matrix_inject[symmetric])
22.135 - apply (rule ext)+
22.136 - apply auto
22.137 - apply (subgoal_tac "Rep_matrix (sparse_row_vector v) 0 a = 0")
22.138 - apply (simp)
22.139 - apply (rule sorted_sparse_row_vector_zero)
22.140 - apply auto
22.141 - done
22.142 -
22.143 -lemma sorted_spvec_minus_spvec:
22.144 - "sorted_spvec v \<Longrightarrow> sorted_spvec (minus_spvec v)"
22.145 - apply (induct v)
22.146 - apply (simp)
22.147 - apply (frule sorted_spvec_cons1, simp)
22.148 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.149 - done
22.150 -
22.151 -lemma sorted_spvec_abs_spvec:
22.152 - "sorted_spvec v \<Longrightarrow> sorted_spvec (abs_spvec v)"
22.153 - apply (induct v)
22.154 - apply (simp)
22.155 - apply (frule sorted_spvec_cons1, simp)
22.156 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.157 - done
22.158 -
22.159 -definition "smult_spvec y = map (% a. (fst a, y * snd a))"
22.160 -
22.161 -lemma smult_spvec_empty[simp]: "smult_spvec y [] = []"
22.162 - by (simp add: smult_spvec_def)
22.163 -
22.164 -lemma smult_spvec_cons: "smult_spvec y (a#arr) = (fst a, y * (snd a)) # (smult_spvec y arr)"
22.165 - by (simp add: smult_spvec_def)
22.166 -
22.167 -fun addmult_spvec :: "('a::ring) \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec"
22.168 -where
22.169 - "addmult_spvec y arr [] = arr"
22.170 -| "addmult_spvec y [] brr = smult_spvec y brr"
22.171 -| "addmult_spvec y ((i,a)#arr) ((j,b)#brr) = (
22.172 - if i < j then ((i,a)#(addmult_spvec y arr ((j,b)#brr)))
22.173 - else (if (j < i) then ((j, y * b)#(addmult_spvec y ((i,a)#arr) brr))
22.174 - else ((i, a + y*b)#(addmult_spvec y arr brr))))"
22.175 -(* Steven used termination "measure (% (y, a, b). length a + (length b))" *)
22.176 -
22.177 -lemma addmult_spvec_empty1[simp]: "addmult_spvec y [] a = smult_spvec y a"
22.178 - by (induct a) auto
22.179 -
22.180 -lemma addmult_spvec_empty2[simp]: "addmult_spvec y a [] = a"
22.181 - by (induct a) auto
22.182 -
22.183 -lemma sparse_row_vector_map: "(! x y. f (x+y) = (f x) + (f y)) \<Longrightarrow> (f::'a\<Rightarrow>('a::lattice_ring)) 0 = 0 \<Longrightarrow>
22.184 - sparse_row_vector (map (% x. (fst x, f (snd x))) a) = apply_matrix f (sparse_row_vector a)"
22.185 - apply (induct a)
22.186 - apply (simp_all add: apply_matrix_add)
22.187 - done
22.188 -
22.189 -lemma sparse_row_vector_smult: "sparse_row_vector (smult_spvec y a) = scalar_mult y (sparse_row_vector a)"
22.190 - apply (induct a)
22.191 - apply (simp_all add: smult_spvec_cons scalar_mult_add)
22.192 - done
22.193 -
22.194 -lemma sparse_row_vector_addmult_spvec: "sparse_row_vector (addmult_spvec (y::'a::lattice_ring) a b) =
22.195 - (sparse_row_vector a) + (scalar_mult y (sparse_row_vector b))"
22.196 - apply (induct y a b rule: addmult_spvec.induct)
22.197 - apply (simp add: scalar_mult_add smult_spvec_cons sparse_row_vector_smult singleton_matrix_add)+
22.198 - done
22.199 -
22.200 -lemma sorted_smult_spvec: "sorted_spvec a \<Longrightarrow> sorted_spvec (smult_spvec y a)"
22.201 - apply (auto simp add: smult_spvec_def)
22.202 - apply (induct a)
22.203 - apply (auto simp add: sorted_spvec.simps split:list.split_asm)
22.204 - done
22.205 -
22.206 -lemma sorted_spvec_addmult_spvec_helper: "\<lbrakk>sorted_spvec (addmult_spvec y ((a, b) # arr) brr); aa < a; sorted_spvec ((a, b) # arr);
22.207 - sorted_spvec ((aa, ba) # brr)\<rbrakk> \<Longrightarrow> sorted_spvec ((aa, y * ba) # addmult_spvec y ((a, b) # arr) brr)"
22.208 - apply (induct brr)
22.209 - apply (auto simp add: sorted_spvec.simps)
22.210 - done
22.211 -
22.212 -lemma sorted_spvec_addmult_spvec_helper2:
22.213 - "\<lbrakk>sorted_spvec (addmult_spvec y arr ((aa, ba) # brr)); a < aa; sorted_spvec ((a, b) # arr); sorted_spvec ((aa, ba) # brr)\<rbrakk>
22.214 - \<Longrightarrow> sorted_spvec ((a, b) # addmult_spvec y arr ((aa, ba) # brr))"
22.215 - apply (induct arr)
22.216 - apply (auto simp add: smult_spvec_def sorted_spvec.simps)
22.217 - done
22.218 -
22.219 -lemma sorted_spvec_addmult_spvec_helper3[rule_format]:
22.220 - "sorted_spvec (addmult_spvec y arr brr) \<longrightarrow> sorted_spvec ((aa, b) # arr) \<longrightarrow> sorted_spvec ((aa, ba) # brr)
22.221 - \<longrightarrow> sorted_spvec ((aa, b + y * ba) # (addmult_spvec y arr brr))"
22.222 - apply (induct y arr brr rule: addmult_spvec.induct)
22.223 - apply (simp_all add: sorted_spvec.simps smult_spvec_def split:list.split)
22.224 - done
22.225 -
22.226 -lemma sorted_addmult_spvec: "sorted_spvec a \<Longrightarrow> sorted_spvec b \<Longrightarrow> sorted_spvec (addmult_spvec y a b)"
22.227 - apply (induct y a b rule: addmult_spvec.induct)
22.228 - apply (simp_all add: sorted_smult_spvec)
22.229 - apply (rule conjI, intro strip)
22.230 - apply (case_tac "~(i < j)")
22.231 - apply (simp_all)
22.232 - apply (frule_tac as=brr in sorted_spvec_cons1)
22.233 - apply (simp add: sorted_spvec_addmult_spvec_helper)
22.234 - apply (intro strip | rule conjI)+
22.235 - apply (frule_tac as=arr in sorted_spvec_cons1)
22.236 - apply (simp add: sorted_spvec_addmult_spvec_helper2)
22.237 - apply (intro strip)
22.238 - apply (frule_tac as=arr in sorted_spvec_cons1)
22.239 - apply (frule_tac as=brr in sorted_spvec_cons1)
22.240 - apply (simp)
22.241 - apply (simp_all add: sorted_spvec_addmult_spvec_helper3)
22.242 - done
22.243 -
22.244 -fun mult_spvec_spmat :: "('a::lattice_ring) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spmat \<Rightarrow> 'a spvec"
22.245 -where
22.246 -(* recdef mult_spvec_spmat "measure (% (c, arr, brr). (length arr) + (length brr))" *)
22.247 - "mult_spvec_spmat c [] brr = c"
22.248 -| "mult_spvec_spmat c arr [] = c"
22.249 -| "mult_spvec_spmat c ((i,a)#arr) ((j,b)#brr) = (
22.250 - if (i < j) then mult_spvec_spmat c arr ((j,b)#brr)
22.251 - else if (j < i) then mult_spvec_spmat c ((i,a)#arr) brr
22.252 - else mult_spvec_spmat (addmult_spvec a c b) arr brr)"
22.253 -
22.254 -lemma sparse_row_mult_spvec_spmat[rule_format]: "sorted_spvec (a::('a::lattice_ring) spvec) \<longrightarrow> sorted_spvec B \<longrightarrow>
22.255 - sparse_row_vector (mult_spvec_spmat c a B) = (sparse_row_vector c) + (sparse_row_vector a) * (sparse_row_matrix B)"
22.256 -proof -
22.257 - have comp_1: "!! a b. a < b \<Longrightarrow> Suc 0 <= nat ((int b)-(int a))" by arith
22.258 - have not_iff: "!! a b. a = b \<Longrightarrow> (~ a) = (~ b)" by simp
22.259 - have max_helper: "!! a b. ~ (a <= max (Suc a) b) \<Longrightarrow> False"
22.260 - by arith
22.261 - {
22.262 - fix a
22.263 - fix v
22.264 - assume a:"a < nrows(sparse_row_vector v)"
22.265 - have b:"nrows(sparse_row_vector v) <= 1" by simp
22.266 - note dummy = less_le_trans[of a "nrows (sparse_row_vector v)" 1, OF a b]
22.267 - then have "a = 0" by simp
22.268 - }
22.269 - note nrows_helper = this
22.270 - show ?thesis
22.271 - apply (induct c a B rule: mult_spvec_spmat.induct)
22.272 - apply simp+
22.273 - apply (rule conjI)
22.274 - apply (intro strip)
22.275 - apply (frule_tac as=brr in sorted_spvec_cons1)
22.276 - apply (simp add: algebra_simps sparse_row_matrix_cons)
22.277 - apply (simplesubst Rep_matrix_zero_imp_mult_zero)
22.278 - apply (simp)
22.279 - apply (rule disjI2)
22.280 - apply (intro strip)
22.281 - apply (subst nrows)
22.282 - apply (rule order_trans[of _ 1])
22.283 - apply (simp add: comp_1)+
22.284 - apply (subst Rep_matrix_zero_imp_mult_zero)
22.285 - apply (intro strip)
22.286 - apply (case_tac "k <= j")
22.287 - apply (rule_tac m1 = k and n1 = i and a1 = a in ssubst[OF sorted_sparse_row_vector_zero])
22.288 - apply (simp_all)
22.289 - apply (rule disjI2)
22.290 - apply (rule nrows)
22.291 - apply (rule order_trans[of _ 1])
22.292 - apply (simp_all add: comp_1)
22.293 -
22.294 - apply (intro strip | rule conjI)+
22.295 - apply (frule_tac as=arr in sorted_spvec_cons1)
22.296 - apply (simp add: algebra_simps)
22.297 - apply (subst Rep_matrix_zero_imp_mult_zero)
22.298 - apply (simp)
22.299 - apply (rule disjI2)
22.300 - apply (intro strip)
22.301 - apply (simp add: sparse_row_matrix_cons)
22.302 - apply (case_tac "i <= j")
22.303 - apply (erule sorted_sparse_row_matrix_zero)
22.304 - apply (simp_all)
22.305 - apply (intro strip)
22.306 - apply (case_tac "i=j")
22.307 - apply (simp_all)
22.308 - apply (frule_tac as=arr in sorted_spvec_cons1)
22.309 - apply (frule_tac as=brr in sorted_spvec_cons1)
22.310 - apply (simp add: sparse_row_matrix_cons algebra_simps sparse_row_vector_addmult_spvec)
22.311 - apply (rule_tac B1 = "sparse_row_matrix brr" in ssubst[OF Rep_matrix_zero_imp_mult_zero])
22.312 - apply (auto)
22.313 - apply (rule sorted_sparse_row_matrix_zero)
22.314 - apply (simp_all)
22.315 - apply (rule_tac A1 = "sparse_row_vector arr" in ssubst[OF Rep_matrix_zero_imp_mult_zero])
22.316 - apply (auto)
22.317 - apply (rule_tac m=k and n = j and a = a and arr=arr in sorted_sparse_row_vector_zero)
22.318 - apply (simp_all)
22.319 - apply (drule nrows_notzero)
22.320 - apply (drule nrows_helper)
22.321 - apply (arith)
22.322 -
22.323 - apply (subst Rep_matrix_inject[symmetric])
22.324 - apply (rule ext)+
22.325 - apply (simp)
22.326 - apply (subst Rep_matrix_mult)
22.327 - apply (rule_tac j1=j in ssubst[OF foldseq_almostzero])
22.328 - apply (simp_all)
22.329 - apply (intro strip, rule conjI)
22.330 - apply (intro strip)
22.331 - apply (drule_tac max_helper)
22.332 - apply (simp)
22.333 - apply (auto)
22.334 - apply (rule zero_imp_mult_zero)
22.335 - apply (rule disjI2)
22.336 - apply (rule nrows)
22.337 - apply (rule order_trans[of _ 1])
22.338 - apply (simp)
22.339 - apply (simp)
22.340 - done
22.341 -qed
22.342 -
22.343 -lemma sorted_mult_spvec_spmat[rule_format]:
22.344 - "sorted_spvec (c::('a::lattice_ring) spvec) \<longrightarrow> sorted_spmat B \<longrightarrow> sorted_spvec (mult_spvec_spmat c a B)"
22.345 - apply (induct c a B rule: mult_spvec_spmat.induct)
22.346 - apply (simp_all add: sorted_addmult_spvec)
22.347 - done
22.348 -
22.349 -primrec mult_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
22.350 -where
22.351 - "mult_spmat [] A = []"
22.352 -| "mult_spmat (a#as) A = (fst a, mult_spvec_spmat [] (snd a) A)#(mult_spmat as A)"
22.353 -
22.354 -lemma sparse_row_mult_spmat:
22.355 - "sorted_spmat A \<Longrightarrow> sorted_spvec B \<Longrightarrow>
22.356 - sparse_row_matrix (mult_spmat A B) = (sparse_row_matrix A) * (sparse_row_matrix B)"
22.357 - apply (induct A)
22.358 - apply (auto simp add: sparse_row_matrix_cons sparse_row_mult_spvec_spmat algebra_simps move_matrix_mult)
22.359 - done
22.360 -
22.361 -lemma sorted_spvec_mult_spmat[rule_format]:
22.362 - "sorted_spvec (A::('a::lattice_ring) spmat) \<longrightarrow> sorted_spvec (mult_spmat A B)"
22.363 - apply (induct A)
22.364 - apply (auto)
22.365 - apply (drule sorted_spvec_cons1, simp)
22.366 - apply (case_tac A)
22.367 - apply (auto simp add: sorted_spvec.simps)
22.368 - done
22.369 -
22.370 -lemma sorted_spmat_mult_spmat:
22.371 - "sorted_spmat (B::('a::lattice_ring) spmat) \<Longrightarrow> sorted_spmat (mult_spmat A B)"
22.372 - apply (induct A)
22.373 - apply (auto simp add: sorted_mult_spvec_spmat)
22.374 - done
22.375 -
22.376 -
22.377 -fun add_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec"
22.378 -where
22.379 -(* "measure (% (a, b). length a + (length b))" *)
22.380 - "add_spvec arr [] = arr"
22.381 -| "add_spvec [] brr = brr"
22.382 -| "add_spvec ((i,a)#arr) ((j,b)#brr) = (
22.383 - if i < j then (i,a)#(add_spvec arr ((j,b)#brr))
22.384 - else if (j < i) then (j,b) # add_spvec ((i,a)#arr) brr
22.385 - else (i, a+b) # add_spvec arr brr)"
22.386 -
22.387 -lemma add_spvec_empty1[simp]: "add_spvec [] a = a"
22.388 -by (cases a, auto)
22.389 -
22.390 -lemma sparse_row_vector_add: "sparse_row_vector (add_spvec a b) = (sparse_row_vector a) + (sparse_row_vector b)"
22.391 - apply (induct a b rule: add_spvec.induct)
22.392 - apply (simp_all add: singleton_matrix_add)
22.393 - done
22.394 -
22.395 -fun add_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
22.396 -where
22.397 -(* "measure (% (A,B). (length A)+(length B))" *)
22.398 - "add_spmat [] bs = bs"
22.399 -| "add_spmat as [] = as"
22.400 -| "add_spmat ((i,a)#as) ((j,b)#bs) = (
22.401 - if i < j then
22.402 - (i,a) # add_spmat as ((j,b)#bs)
22.403 - else if j < i then
22.404 - (j,b) # add_spmat ((i,a)#as) bs
22.405 - else
22.406 - (i, add_spvec a b) # add_spmat as bs)"
22.407 -
22.408 -lemma add_spmat_Nil2[simp]: "add_spmat as [] = as"
22.409 -by(cases as) auto
22.410 -
22.411 -lemma sparse_row_add_spmat: "sparse_row_matrix (add_spmat A B) = (sparse_row_matrix A) + (sparse_row_matrix B)"
22.412 - apply (induct A B rule: add_spmat.induct)
22.413 - apply (auto simp add: sparse_row_matrix_cons sparse_row_vector_add move_matrix_add)
22.414 - done
22.415 -
22.416 -lemmas [code] = sparse_row_add_spmat [symmetric]
22.417 -lemmas [code] = sparse_row_vector_add [symmetric]
22.418 -
22.419 -lemma sorted_add_spvec_helper1[rule_format]: "add_spvec ((a,b)#arr) brr = (ab, bb) # list \<longrightarrow> (ab = a | (brr \<noteq> [] & ab = fst (hd brr)))"
22.420 - proof -
22.421 - have "(! x ab a. x = (a,b)#arr \<longrightarrow> add_spvec x brr = (ab, bb) # list \<longrightarrow> (ab = a | (ab = fst (hd brr))))"
22.422 - by (induct brr rule: add_spvec.induct) (auto split:if_splits)
22.423 - then show ?thesis
22.424 - by (case_tac brr, auto)
22.425 - qed
22.426 -
22.427 -lemma sorted_add_spmat_helper1[rule_format]: "add_spmat ((a,b)#arr) brr = (ab, bb) # list \<longrightarrow> (ab = a | (brr \<noteq> [] & ab = fst (hd brr)))"
22.428 - proof -
22.429 - have "(! x ab a. x = (a,b)#arr \<longrightarrow> add_spmat x brr = (ab, bb) # list \<longrightarrow> (ab = a | (ab = fst (hd brr))))"
22.430 - by (rule add_spmat.induct) (auto split:if_splits)
22.431 - then show ?thesis
22.432 - by (case_tac brr, auto)
22.433 - qed
22.434 -
22.435 -lemma sorted_add_spvec_helper: "add_spvec arr brr = (ab, bb) # list \<Longrightarrow> ((arr \<noteq> [] & ab = fst (hd arr)) | (brr \<noteq> [] & ab = fst (hd brr)))"
22.436 - apply (induct arr brr rule: add_spvec.induct)
22.437 - apply (auto split:if_splits)
22.438 - done
22.439 -
22.440 -lemma sorted_add_spmat_helper: "add_spmat arr brr = (ab, bb) # list \<Longrightarrow> ((arr \<noteq> [] & ab = fst (hd arr)) | (brr \<noteq> [] & ab = fst (hd brr)))"
22.441 - apply (induct arr brr rule: add_spmat.induct)
22.442 - apply (auto split:if_splits)
22.443 - done
22.444 -
22.445 -lemma add_spvec_commute: "add_spvec a b = add_spvec b a"
22.446 -by (induct a b rule: add_spvec.induct) auto
22.447 -
22.448 -lemma add_spmat_commute: "add_spmat a b = add_spmat b a"
22.449 - apply (induct a b rule: add_spmat.induct)
22.450 - apply (simp_all add: add_spvec_commute)
22.451 - done
22.452 -
22.453 -lemma sorted_add_spvec_helper2: "add_spvec ((a,b)#arr) brr = (ab, bb) # list \<Longrightarrow> aa < a \<Longrightarrow> sorted_spvec ((aa, ba) # brr) \<Longrightarrow> aa < ab"
22.454 - apply (drule sorted_add_spvec_helper1)
22.455 - apply (auto)
22.456 - apply (case_tac brr)
22.457 - apply (simp_all)
22.458 - apply (drule_tac sorted_spvec_cons3)
22.459 - apply (simp)
22.460 - done
22.461 -
22.462 -lemma sorted_add_spmat_helper2: "add_spmat ((a,b)#arr) brr = (ab, bb) # list \<Longrightarrow> aa < a \<Longrightarrow> sorted_spvec ((aa, ba) # brr) \<Longrightarrow> aa < ab"
22.463 - apply (drule sorted_add_spmat_helper1)
22.464 - apply (auto)
22.465 - apply (case_tac brr)
22.466 - apply (simp_all)
22.467 - apply (drule_tac sorted_spvec_cons3)
22.468 - apply (simp)
22.469 - done
22.470 -
22.471 -lemma sorted_spvec_add_spvec[rule_format]: "sorted_spvec a \<longrightarrow> sorted_spvec b \<longrightarrow> sorted_spvec (add_spvec a b)"
22.472 - apply (induct a b rule: add_spvec.induct)
22.473 - apply (simp_all)
22.474 - apply (rule conjI)
22.475 - apply (clarsimp)
22.476 - apply (frule_tac as=brr in sorted_spvec_cons1)
22.477 - apply (simp)
22.478 - apply (subst sorted_spvec_step)
22.479 - apply (clarsimp simp: sorted_add_spvec_helper2 split: list.split)
22.480 - apply (clarify)
22.481 - apply (rule conjI)
22.482 - apply (clarify)
22.483 - apply (frule_tac as=arr in sorted_spvec_cons1, simp)
22.484 - apply (subst sorted_spvec_step)
22.485 - apply (clarsimp simp: sorted_add_spvec_helper2 add_spvec_commute split: list.split)
22.486 - apply (clarify)
22.487 - apply (frule_tac as=arr in sorted_spvec_cons1)
22.488 - apply (frule_tac as=brr in sorted_spvec_cons1)
22.489 - apply (simp)
22.490 - apply (subst sorted_spvec_step)
22.491 - apply (simp split: list.split)
22.492 - apply (clarsimp)
22.493 - apply (drule_tac sorted_add_spvec_helper)
22.494 - apply (auto simp: neq_Nil_conv)
22.495 - apply (drule sorted_spvec_cons3)
22.496 - apply (simp)
22.497 - apply (drule sorted_spvec_cons3)
22.498 - apply (simp)
22.499 - done
22.500 -
22.501 -lemma sorted_spvec_add_spmat[rule_format]: "sorted_spvec A \<longrightarrow> sorted_spvec B \<longrightarrow> sorted_spvec (add_spmat A B)"
22.502 - apply (induct A B rule: add_spmat.induct)
22.503 - apply (simp_all)
22.504 - apply (rule conjI)
22.505 - apply (intro strip)
22.506 - apply (simp)
22.507 - apply (frule_tac as=bs in sorted_spvec_cons1)
22.508 - apply (simp)
22.509 - apply (subst sorted_spvec_step)
22.510 - apply (simp split: list.split)
22.511 - apply (clarify, simp)
22.512 - apply (simp add: sorted_add_spmat_helper2)
22.513 - apply (clarify)
22.514 - apply (rule conjI)
22.515 - apply (clarify)
22.516 - apply (frule_tac as=as in sorted_spvec_cons1, simp)
22.517 - apply (subst sorted_spvec_step)
22.518 - apply (clarsimp simp: sorted_add_spmat_helper2 add_spmat_commute split: list.split)
22.519 - apply (clarsimp)
22.520 - apply (frule_tac as=as in sorted_spvec_cons1)
22.521 - apply (frule_tac as=bs in sorted_spvec_cons1)
22.522 - apply (simp)
22.523 - apply (subst sorted_spvec_step)
22.524 - apply (simp split: list.split)
22.525 - apply (clarify, simp)
22.526 - apply (drule_tac sorted_add_spmat_helper)
22.527 - apply (auto simp:neq_Nil_conv)
22.528 - apply (drule sorted_spvec_cons3)
22.529 - apply (simp)
22.530 - apply (drule sorted_spvec_cons3)
22.531 - apply (simp)
22.532 - done
22.533 -
22.534 -lemma sorted_spmat_add_spmat[rule_format]: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (add_spmat A B)"
22.535 - apply (induct A B rule: add_spmat.induct)
22.536 - apply (simp_all add: sorted_spvec_add_spvec)
22.537 - done
22.538 -
22.539 -fun le_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> bool"
22.540 -where
22.541 -(* "measure (% (a,b). (length a) + (length b))" *)
22.542 - "le_spvec [] [] = True"
22.543 -| "le_spvec ((_,a)#as) [] = (a <= 0 & le_spvec as [])"
22.544 -| "le_spvec [] ((_,b)#bs) = (0 <= b & le_spvec [] bs)"
22.545 -| "le_spvec ((i,a)#as) ((j,b)#bs) = (
22.546 - if (i < j) then a <= 0 & le_spvec as ((j,b)#bs)
22.547 - else if (j < i) then 0 <= b & le_spvec ((i,a)#as) bs
22.548 - else a <= b & le_spvec as bs)"
22.549 -
22.550 -fun le_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> bool"
22.551 -where
22.552 -(* "measure (% (a,b). (length a) + (length b))" *)
22.553 - "le_spmat [] [] = True"
22.554 -| "le_spmat ((i,a)#as) [] = (le_spvec a [] & le_spmat as [])"
22.555 -| "le_spmat [] ((j,b)#bs) = (le_spvec [] b & le_spmat [] bs)"
22.556 -| "le_spmat ((i,a)#as) ((j,b)#bs) = (
22.557 - if i < j then (le_spvec a [] & le_spmat as ((j,b)#bs))
22.558 - else if j < i then (le_spvec [] b & le_spmat ((i,a)#as) bs)
22.559 - else (le_spvec a b & le_spmat as bs))"
22.560 -
22.561 -definition disj_matrices :: "('a::zero) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
22.562 - "disj_matrices A B \<longleftrightarrow>
22.563 - (! j i. (Rep_matrix A j i \<noteq> 0) \<longrightarrow> (Rep_matrix B j i = 0)) & (! j i. (Rep_matrix B j i \<noteq> 0) \<longrightarrow> (Rep_matrix A j i = 0))"
22.564 -
22.565 -declare [[simp_depth_limit = 6]]
22.566 -
22.567 -lemma disj_matrices_contr1: "disj_matrices A B \<Longrightarrow> Rep_matrix A j i \<noteq> 0 \<Longrightarrow> Rep_matrix B j i = 0"
22.568 - by (simp add: disj_matrices_def)
22.569 -
22.570 -lemma disj_matrices_contr2: "disj_matrices A B \<Longrightarrow> Rep_matrix B j i \<noteq> 0 \<Longrightarrow> Rep_matrix A j i = 0"
22.571 - by (simp add: disj_matrices_def)
22.572 -
22.573 -
22.574 -lemma disj_matrices_add: "disj_matrices A B \<Longrightarrow> disj_matrices C D \<Longrightarrow> disj_matrices A D \<Longrightarrow> disj_matrices B C \<Longrightarrow>
22.575 - (A + B <= C + D) = (A <= C & B <= (D::('a::lattice_ab_group_add) matrix))"
22.576 - apply (auto)
22.577 - apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
22.578 - apply (intro strip)
22.579 - apply (erule conjE)+
22.580 - apply (drule_tac j=j and i=i in spec2)+
22.581 - apply (case_tac "Rep_matrix B j i = 0")
22.582 - apply (case_tac "Rep_matrix D j i = 0")
22.583 - apply (simp_all)
22.584 - apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
22.585 - apply (intro strip)
22.586 - apply (erule conjE)+
22.587 - apply (drule_tac j=j and i=i in spec2)+
22.588 - apply (case_tac "Rep_matrix A j i = 0")
22.589 - apply (case_tac "Rep_matrix C j i = 0")
22.590 - apply (simp_all)
22.591 - apply (erule add_mono)
22.592 - apply (assumption)
22.593 - done
22.594 -
22.595 -lemma disj_matrices_zero1[simp]: "disj_matrices 0 B"
22.596 -by (simp add: disj_matrices_def)
22.597 -
22.598 -lemma disj_matrices_zero2[simp]: "disj_matrices A 0"
22.599 -by (simp add: disj_matrices_def)
22.600 -
22.601 -lemma disj_matrices_commute: "disj_matrices A B = disj_matrices B A"
22.602 -by (auto simp add: disj_matrices_def)
22.603 -
22.604 -lemma disj_matrices_add_le_zero: "disj_matrices A B \<Longrightarrow>
22.605 - (A + B <= 0) = (A <= 0 & (B::('a::lattice_ab_group_add) matrix) <= 0)"
22.606 -by (rule disj_matrices_add[of A B 0 0, simplified])
22.607 -
22.608 -lemma disj_matrices_add_zero_le: "disj_matrices A B \<Longrightarrow>
22.609 - (0 <= A + B) = (0 <= A & 0 <= (B::('a::lattice_ab_group_add) matrix))"
22.610 -by (rule disj_matrices_add[of 0 0 A B, simplified])
22.611 -
22.612 -lemma disj_matrices_add_x_le: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
22.613 - (A <= B + C) = (A <= C & 0 <= (B::('a::lattice_ab_group_add) matrix))"
22.614 -by (auto simp add: disj_matrices_add[of 0 A B C, simplified])
22.615 -
22.616 -lemma disj_matrices_add_le_x: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
22.617 - (B + A <= C) = (A <= C & (B::('a::lattice_ab_group_add) matrix) <= 0)"
22.618 -by (auto simp add: disj_matrices_add[of B A 0 C,simplified] disj_matrices_commute)
22.619 -
22.620 -lemma disj_sparse_row_singleton: "i <= j \<Longrightarrow> sorted_spvec((j,y)#v) \<Longrightarrow> disj_matrices (sparse_row_vector v) (singleton_matrix 0 i x)"
22.621 - apply (simp add: disj_matrices_def)
22.622 - apply (rule conjI)
22.623 - apply (rule neg_imp)
22.624 - apply (simp)
22.625 - apply (intro strip)
22.626 - apply (rule sorted_sparse_row_vector_zero)
22.627 - apply (simp_all)
22.628 - apply (intro strip)
22.629 - apply (rule sorted_sparse_row_vector_zero)
22.630 - apply (simp_all)
22.631 - done
22.632 -
22.633 -lemma disj_matrices_x_add: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (A::('a::lattice_ab_group_add) matrix) (B+C)"
22.634 - apply (simp add: disj_matrices_def)
22.635 - apply (auto)
22.636 - apply (drule_tac j=j and i=i in spec2)+
22.637 - apply (case_tac "Rep_matrix B j i = 0")
22.638 - apply (case_tac "Rep_matrix C j i = 0")
22.639 - apply (simp_all)
22.640 - done
22.641 -
22.642 -lemma disj_matrices_add_x: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (B+C) (A::('a::lattice_ab_group_add) matrix)"
22.643 - by (simp add: disj_matrices_x_add disj_matrices_commute)
22.644 -
22.645 -lemma disj_singleton_matrices[simp]: "disj_matrices (singleton_matrix j i x) (singleton_matrix u v y) = (j \<noteq> u | i \<noteq> v | x = 0 | y = 0)"
22.646 - by (auto simp add: disj_matrices_def)
22.647 -
22.648 -lemma disj_move_sparse_vec_mat[simplified disj_matrices_commute]:
22.649 - "j <= a \<Longrightarrow> sorted_spvec((a,c)#as) \<Longrightarrow> disj_matrices (move_matrix (sparse_row_vector b) (int j) i) (sparse_row_matrix as)"
22.650 - apply (auto simp add: disj_matrices_def)
22.651 - apply (drule nrows_notzero)
22.652 - apply (drule less_le_trans[OF _ nrows_spvec])
22.653 - apply (subgoal_tac "ja = j")
22.654 - apply (simp add: sorted_sparse_row_matrix_zero)
22.655 - apply (arith)
22.656 - apply (rule nrows)
22.657 - apply (rule order_trans[of _ 1 _])
22.658 - apply (simp)
22.659 - apply (case_tac "nat (int ja - int j) = 0")
22.660 - apply (case_tac "ja = j")
22.661 - apply (simp add: sorted_sparse_row_matrix_zero)
22.662 - apply arith+
22.663 - done
22.664 -
22.665 -lemma disj_move_sparse_row_vector_twice:
22.666 - "j \<noteq> u \<Longrightarrow> disj_matrices (move_matrix (sparse_row_vector a) j i) (move_matrix (sparse_row_vector b) u v)"
22.667 - apply (auto simp add: disj_matrices_def)
22.668 - apply (rule nrows, rule order_trans[of _ 1], simp, drule nrows_notzero, drule less_le_trans[OF _ nrows_spvec], arith)+
22.669 - done
22.670 -
22.671 -lemma le_spvec_iff_sparse_row_le[rule_format]: "(sorted_spvec a) \<longrightarrow> (sorted_spvec b) \<longrightarrow> (le_spvec a b) = (sparse_row_vector a <= sparse_row_vector b)"
22.672 - apply (induct a b rule: le_spvec.induct)
22.673 - apply (simp_all add: sorted_spvec_cons1 disj_matrices_add_le_zero disj_matrices_add_zero_le
22.674 - disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
22.675 - apply (rule conjI, intro strip)
22.676 - apply (simp add: sorted_spvec_cons1)
22.677 - apply (subst disj_matrices_add_x_le)
22.678 - apply (simp add: disj_sparse_row_singleton[OF less_imp_le] disj_matrices_x_add disj_matrices_commute)
22.679 - apply (simp add: disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
22.680 - apply (simp, blast)
22.681 - apply (intro strip, rule conjI, intro strip)
22.682 - apply (simp add: sorted_spvec_cons1)
22.683 - apply (subst disj_matrices_add_le_x)
22.684 - apply (simp_all add: disj_sparse_row_singleton[OF order_refl] disj_sparse_row_singleton[OF less_imp_le] disj_matrices_commute disj_matrices_x_add)
22.685 - apply (blast)
22.686 - apply (intro strip)
22.687 - apply (simp add: sorted_spvec_cons1)
22.688 - apply (case_tac "a=b", simp_all)
22.689 - apply (subst disj_matrices_add)
22.690 - apply (simp_all add: disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
22.691 - done
22.692 -
22.693 -lemma le_spvec_empty2_sparse_row[rule_format]: "sorted_spvec b \<longrightarrow> le_spvec b [] = (sparse_row_vector b <= 0)"
22.694 - apply (induct b)
22.695 - apply (simp_all add: sorted_spvec_cons1)
22.696 - apply (intro strip)
22.697 - apply (subst disj_matrices_add_le_zero)
22.698 - apply (auto simp add: disj_matrices_commute disj_sparse_row_singleton[OF order_refl] sorted_spvec_cons1)
22.699 - done
22.700 -
22.701 -lemma le_spvec_empty1_sparse_row[rule_format]: "(sorted_spvec b) \<longrightarrow> (le_spvec [] b = (0 <= sparse_row_vector b))"
22.702 - apply (induct b)
22.703 - apply (simp_all add: sorted_spvec_cons1)
22.704 - apply (intro strip)
22.705 - apply (subst disj_matrices_add_zero_le)
22.706 - apply (auto simp add: disj_matrices_commute disj_sparse_row_singleton[OF order_refl] sorted_spvec_cons1)
22.707 - done
22.708 -
22.709 -lemma le_spmat_iff_sparse_row_le[rule_format]: "(sorted_spvec A) \<longrightarrow> (sorted_spmat A) \<longrightarrow> (sorted_spvec B) \<longrightarrow> (sorted_spmat B) \<longrightarrow>
22.710 - le_spmat A B = (sparse_row_matrix A <= sparse_row_matrix B)"
22.711 - apply (induct A B rule: le_spmat.induct)
22.712 - apply (simp add: sparse_row_matrix_cons disj_matrices_add_le_zero disj_matrices_add_zero_le disj_move_sparse_vec_mat[OF order_refl]
22.713 - disj_matrices_commute sorted_spvec_cons1 le_spvec_empty2_sparse_row le_spvec_empty1_sparse_row)+
22.714 - apply (rule conjI, intro strip)
22.715 - apply (simp add: sorted_spvec_cons1)
22.716 - apply (subst disj_matrices_add_x_le)
22.717 - apply (rule disj_matrices_add_x)
22.718 - apply (simp add: disj_move_sparse_row_vector_twice)
22.719 - apply (simp add: disj_move_sparse_vec_mat[OF less_imp_le] disj_matrices_commute)
22.720 - apply (simp add: disj_move_sparse_vec_mat[OF order_refl] disj_matrices_commute)
22.721 - apply (simp, blast)
22.722 - apply (intro strip, rule conjI, intro strip)
22.723 - apply (simp add: sorted_spvec_cons1)
22.724 - apply (subst disj_matrices_add_le_x)
22.725 - apply (simp add: disj_move_sparse_vec_mat[OF order_refl])
22.726 - apply (rule disj_matrices_x_add)
22.727 - apply (simp add: disj_move_sparse_row_vector_twice)
22.728 - apply (simp add: disj_move_sparse_vec_mat[OF less_imp_le] disj_matrices_commute)
22.729 - apply (simp, blast)
22.730 - apply (intro strip)
22.731 - apply (case_tac "i=j")
22.732 - apply (simp_all)
22.733 - apply (subst disj_matrices_add)
22.734 - apply (simp_all add: disj_matrices_commute disj_move_sparse_vec_mat[OF order_refl])
22.735 - apply (simp add: sorted_spvec_cons1 le_spvec_iff_sparse_row_le)
22.736 - done
22.737 -
22.738 -declare [[simp_depth_limit = 999]]
22.739 -
22.740 -primrec abs_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat"
22.741 -where
22.742 - "abs_spmat [] = []"
22.743 -| "abs_spmat (a#as) = (fst a, abs_spvec (snd a))#(abs_spmat as)"
22.744 -
22.745 -primrec minus_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat"
22.746 -where
22.747 - "minus_spmat [] = []"
22.748 -| "minus_spmat (a#as) = (fst a, minus_spvec (snd a))#(minus_spmat as)"
22.749 -
22.750 -lemma sparse_row_matrix_minus:
22.751 - "sparse_row_matrix (minus_spmat A) = - (sparse_row_matrix A)"
22.752 - apply (induct A)
22.753 - apply (simp_all add: sparse_row_vector_minus sparse_row_matrix_cons)
22.754 - apply (subst Rep_matrix_inject[symmetric])
22.755 - apply (rule ext)+
22.756 - apply simp
22.757 - done
22.758 -
22.759 -lemma Rep_sparse_row_vector_zero: "x \<noteq> 0 \<Longrightarrow> Rep_matrix (sparse_row_vector v) x y = 0"
22.760 -proof -
22.761 - assume x:"x \<noteq> 0"
22.762 - have r:"nrows (sparse_row_vector v) <= Suc 0" by (rule nrows_spvec)
22.763 - show ?thesis
22.764 - apply (rule nrows)
22.765 - apply (subgoal_tac "Suc 0 <= x")
22.766 - apply (insert r)
22.767 - apply (simp only:)
22.768 - apply (insert x)
22.769 - apply arith
22.770 - done
22.771 -qed
22.772 -
22.773 -lemma sparse_row_matrix_abs:
22.774 - "sorted_spvec A \<Longrightarrow> sorted_spmat A \<Longrightarrow> sparse_row_matrix (abs_spmat A) = abs (sparse_row_matrix A)"
22.775 - apply (induct A)
22.776 - apply (simp_all add: sparse_row_vector_abs sparse_row_matrix_cons)
22.777 - apply (frule_tac sorted_spvec_cons1, simp)
22.778 - apply (simplesubst Rep_matrix_inject[symmetric])
22.779 - apply (rule ext)+
22.780 - apply auto
22.781 - apply (case_tac "x=a")
22.782 - apply (simp)
22.783 - apply (simplesubst sorted_sparse_row_matrix_zero)
22.784 - apply auto
22.785 - apply (simplesubst Rep_sparse_row_vector_zero)
22.786 - apply simp_all
22.787 - done
22.788 -
22.789 -lemma sorted_spvec_minus_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec (minus_spmat A)"
22.790 - apply (induct A)
22.791 - apply (simp)
22.792 - apply (frule sorted_spvec_cons1, simp)
22.793 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.794 - done
22.795 -
22.796 -lemma sorted_spvec_abs_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec (abs_spmat A)"
22.797 - apply (induct A)
22.798 - apply (simp)
22.799 - apply (frule sorted_spvec_cons1, simp)
22.800 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.801 - done
22.802 -
22.803 -lemma sorted_spmat_minus_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat (minus_spmat A)"
22.804 - apply (induct A)
22.805 - apply (simp_all add: sorted_spvec_minus_spvec)
22.806 - done
22.807 -
22.808 -lemma sorted_spmat_abs_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat (abs_spmat A)"
22.809 - apply (induct A)
22.810 - apply (simp_all add: sorted_spvec_abs_spvec)
22.811 - done
22.812 -
22.813 -definition diff_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
22.814 - where "diff_spmat A B = add_spmat A (minus_spmat B)"
22.815 -
22.816 -lemma sorted_spmat_diff_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (diff_spmat A B)"
22.817 - by (simp add: diff_spmat_def sorted_spmat_minus_spmat sorted_spmat_add_spmat)
22.818 -
22.819 -lemma sorted_spvec_diff_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec B \<Longrightarrow> sorted_spvec (diff_spmat A B)"
22.820 - by (simp add: diff_spmat_def sorted_spvec_minus_spmat sorted_spvec_add_spmat)
22.821 -
22.822 -lemma sparse_row_diff_spmat: "sparse_row_matrix (diff_spmat A B ) = (sparse_row_matrix A) - (sparse_row_matrix B)"
22.823 - by (simp add: diff_spmat_def sparse_row_add_spmat sparse_row_matrix_minus)
22.824 -
22.825 -definition sorted_sparse_matrix :: "'a spmat \<Rightarrow> bool"
22.826 - where "sorted_sparse_matrix A \<longleftrightarrow> sorted_spvec A & sorted_spmat A"
22.827 -
22.828 -lemma sorted_sparse_matrix_imp_spvec: "sorted_sparse_matrix A \<Longrightarrow> sorted_spvec A"
22.829 - by (simp add: sorted_sparse_matrix_def)
22.830 -
22.831 -lemma sorted_sparse_matrix_imp_spmat: "sorted_sparse_matrix A \<Longrightarrow> sorted_spmat A"
22.832 - by (simp add: sorted_sparse_matrix_def)
22.833 -
22.834 -lemmas sorted_sp_simps =
22.835 - sorted_spvec.simps
22.836 - sorted_spmat.simps
22.837 - sorted_sparse_matrix_def
22.838 -
22.839 -lemma bool1: "(\<not> True) = False" by blast
22.840 -lemma bool2: "(\<not> False) = True" by blast
22.841 -lemma bool3: "((P\<Colon>bool) \<and> True) = P" by blast
22.842 -lemma bool4: "(True \<and> (P\<Colon>bool)) = P" by blast
22.843 -lemma bool5: "((P\<Colon>bool) \<and> False) = False" by blast
22.844 -lemma bool6: "(False \<and> (P\<Colon>bool)) = False" by blast
22.845 -lemma bool7: "((P\<Colon>bool) \<or> True) = True" by blast
22.846 -lemma bool8: "(True \<or> (P\<Colon>bool)) = True" by blast
22.847 -lemma bool9: "((P\<Colon>bool) \<or> False) = P" by blast
22.848 -lemma bool10: "(False \<or> (P\<Colon>bool)) = P" by blast
22.849 -lemmas boolarith = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10
22.850 -
22.851 -lemma if_case_eq: "(if b then x else y) = (case b of True => x | False => y)" by simp
22.852 -
22.853 -primrec pprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
22.854 -where
22.855 - "pprt_spvec [] = []"
22.856 -| "pprt_spvec (a#as) = (fst a, pprt (snd a)) # (pprt_spvec as)"
22.857 -
22.858 -primrec nprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
22.859 -where
22.860 - "nprt_spvec [] = []"
22.861 -| "nprt_spvec (a#as) = (fst a, nprt (snd a)) # (nprt_spvec as)"
22.862 -
22.863 -primrec pprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
22.864 -where
22.865 - "pprt_spmat [] = []"
22.866 -| "pprt_spmat (a#as) = (fst a, pprt_spvec (snd a))#(pprt_spmat as)"
22.867 -
22.868 -primrec nprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
22.869 -where
22.870 - "nprt_spmat [] = []"
22.871 -| "nprt_spmat (a#as) = (fst a, nprt_spvec (snd a))#(nprt_spmat as)"
22.872 -
22.873 -
22.874 -lemma pprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> pprt (A+B) = pprt A + pprt B"
22.875 - apply (simp add: pprt_def sup_matrix_def)
22.876 - apply (simp add: Rep_matrix_inject[symmetric])
22.877 - apply (rule ext)+
22.878 - apply simp
22.879 - apply (case_tac "Rep_matrix A x xa \<noteq> 0")
22.880 - apply (simp_all add: disj_matrices_contr1)
22.881 - done
22.882 -
22.883 -lemma nprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> nprt (A+B) = nprt A + nprt B"
22.884 - apply (simp add: nprt_def inf_matrix_def)
22.885 - apply (simp add: Rep_matrix_inject[symmetric])
22.886 - apply (rule ext)+
22.887 - apply simp
22.888 - apply (case_tac "Rep_matrix A x xa \<noteq> 0")
22.889 - apply (simp_all add: disj_matrices_contr1)
22.890 - done
22.891 -
22.892 -lemma pprt_singleton[simp]: "pprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (pprt x)"
22.893 - apply (simp add: pprt_def sup_matrix_def)
22.894 - apply (simp add: Rep_matrix_inject[symmetric])
22.895 - apply (rule ext)+
22.896 - apply simp
22.897 - done
22.898 -
22.899 -lemma nprt_singleton[simp]: "nprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (nprt x)"
22.900 - apply (simp add: nprt_def inf_matrix_def)
22.901 - apply (simp add: Rep_matrix_inject[symmetric])
22.902 - apply (rule ext)+
22.903 - apply simp
22.904 - done
22.905 -
22.906 -lemma less_imp_le: "a < b \<Longrightarrow> a <= (b::_::order)" by (simp add: less_def)
22.907 -
22.908 -lemma sparse_row_vector_pprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (pprt_spvec v) = pprt (sparse_row_vector v)"
22.909 - apply (induct v)
22.910 - apply (simp_all)
22.911 - apply (frule sorted_spvec_cons1, auto)
22.912 - apply (subst pprt_add)
22.913 - apply (subst disj_matrices_commute)
22.914 - apply (rule disj_sparse_row_singleton)
22.915 - apply auto
22.916 - done
22.917 -
22.918 -lemma sparse_row_vector_nprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (nprt_spvec v) = nprt (sparse_row_vector v)"
22.919 - apply (induct v)
22.920 - apply (simp_all)
22.921 - apply (frule sorted_spvec_cons1, auto)
22.922 - apply (subst nprt_add)
22.923 - apply (subst disj_matrices_commute)
22.924 - apply (rule disj_sparse_row_singleton)
22.925 - apply auto
22.926 - done
22.927 -
22.928 -
22.929 -lemma pprt_move_matrix: "pprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (pprt A) j i"
22.930 - apply (simp add: pprt_def)
22.931 - apply (simp add: sup_matrix_def)
22.932 - apply (simp add: Rep_matrix_inject[symmetric])
22.933 - apply (rule ext)+
22.934 - apply (simp)
22.935 - done
22.936 -
22.937 -lemma nprt_move_matrix: "nprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (nprt A) j i"
22.938 - apply (simp add: nprt_def)
22.939 - apply (simp add: inf_matrix_def)
22.940 - apply (simp add: Rep_matrix_inject[symmetric])
22.941 - apply (rule ext)+
22.942 - apply (simp)
22.943 - done
22.944 -
22.945 -lemma sparse_row_matrix_pprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (pprt_spmat m) = pprt (sparse_row_matrix m)"
22.946 - apply (induct m)
22.947 - apply simp
22.948 - apply simp
22.949 - apply (frule sorted_spvec_cons1)
22.950 - apply (simp add: sparse_row_matrix_cons sparse_row_vector_pprt)
22.951 - apply (subst pprt_add)
22.952 - apply (subst disj_matrices_commute)
22.953 - apply (rule disj_move_sparse_vec_mat)
22.954 - apply auto
22.955 - apply (simp add: sorted_spvec.simps)
22.956 - apply (simp split: list.split)
22.957 - apply auto
22.958 - apply (simp add: pprt_move_matrix)
22.959 - done
22.960 -
22.961 -lemma sparse_row_matrix_nprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (nprt_spmat m) = nprt (sparse_row_matrix m)"
22.962 - apply (induct m)
22.963 - apply simp
22.964 - apply simp
22.965 - apply (frule sorted_spvec_cons1)
22.966 - apply (simp add: sparse_row_matrix_cons sparse_row_vector_nprt)
22.967 - apply (subst nprt_add)
22.968 - apply (subst disj_matrices_commute)
22.969 - apply (rule disj_move_sparse_vec_mat)
22.970 - apply auto
22.971 - apply (simp add: sorted_spvec.simps)
22.972 - apply (simp split: list.split)
22.973 - apply auto
22.974 - apply (simp add: nprt_move_matrix)
22.975 - done
22.976 -
22.977 -lemma sorted_pprt_spvec: "sorted_spvec v \<Longrightarrow> sorted_spvec (pprt_spvec v)"
22.978 - apply (induct v)
22.979 - apply (simp)
22.980 - apply (frule sorted_spvec_cons1)
22.981 - apply simp
22.982 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.983 - done
22.984 -
22.985 -lemma sorted_nprt_spvec: "sorted_spvec v \<Longrightarrow> sorted_spvec (nprt_spvec v)"
22.986 - apply (induct v)
22.987 - apply (simp)
22.988 - apply (frule sorted_spvec_cons1)
22.989 - apply simp
22.990 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.991 - done
22.992 -
22.993 -lemma sorted_spvec_pprt_spmat: "sorted_spvec m \<Longrightarrow> sorted_spvec (pprt_spmat m)"
22.994 - apply (induct m)
22.995 - apply (simp)
22.996 - apply (frule sorted_spvec_cons1)
22.997 - apply simp
22.998 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.999 - done
22.1000 -
22.1001 -lemma sorted_spvec_nprt_spmat: "sorted_spvec m \<Longrightarrow> sorted_spvec (nprt_spmat m)"
22.1002 - apply (induct m)
22.1003 - apply (simp)
22.1004 - apply (frule sorted_spvec_cons1)
22.1005 - apply simp
22.1006 - apply (simp add: sorted_spvec.simps split:list.split_asm)
22.1007 - done
22.1008 -
22.1009 -lemma sorted_spmat_pprt_spmat: "sorted_spmat m \<Longrightarrow> sorted_spmat (pprt_spmat m)"
22.1010 - apply (induct m)
22.1011 - apply (simp_all add: sorted_pprt_spvec)
22.1012 - done
22.1013 -
22.1014 -lemma sorted_spmat_nprt_spmat: "sorted_spmat m \<Longrightarrow> sorted_spmat (nprt_spmat m)"
22.1015 - apply (induct m)
22.1016 - apply (simp_all add: sorted_nprt_spvec)
22.1017 - done
22.1018 -
22.1019 -definition mult_est_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat" where
22.1020 - "mult_est_spmat r1 r2 s1 s2 =
22.1021 - add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
22.1022 - (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))"
22.1023 -
22.1024 -lemmas sparse_row_matrix_op_simps =
22.1025 - sorted_sparse_matrix_imp_spmat sorted_sparse_matrix_imp_spvec
22.1026 - sparse_row_add_spmat sorted_spvec_add_spmat sorted_spmat_add_spmat
22.1027 - sparse_row_diff_spmat sorted_spvec_diff_spmat sorted_spmat_diff_spmat
22.1028 - sparse_row_matrix_minus sorted_spvec_minus_spmat sorted_spmat_minus_spmat
22.1029 - sparse_row_mult_spmat sorted_spvec_mult_spmat sorted_spmat_mult_spmat
22.1030 - sparse_row_matrix_abs sorted_spvec_abs_spmat sorted_spmat_abs_spmat
22.1031 - le_spmat_iff_sparse_row_le
22.1032 - sparse_row_matrix_pprt sorted_spvec_pprt_spmat sorted_spmat_pprt_spmat
22.1033 - sparse_row_matrix_nprt sorted_spvec_nprt_spmat sorted_spmat_nprt_spmat
22.1034 -
22.1035 -lemma zero_eq_Numeral0: "(0::_::number_ring) = Numeral0" by simp
22.1036 -
22.1037 -lemmas sparse_row_matrix_arith_simps[simplified zero_eq_Numeral0] =
22.1038 - mult_spmat.simps mult_spvec_spmat.simps
22.1039 - addmult_spvec.simps
22.1040 - smult_spvec_empty smult_spvec_cons
22.1041 - add_spmat.simps add_spvec.simps
22.1042 - minus_spmat.simps minus_spvec.simps
22.1043 - abs_spmat.simps abs_spvec.simps
22.1044 - diff_spmat_def
22.1045 - le_spmat.simps le_spvec.simps
22.1046 - pprt_spmat.simps pprt_spvec.simps
22.1047 - nprt_spmat.simps nprt_spvec.simps
22.1048 - mult_est_spmat_def
22.1049 -
22.1050 -
22.1051 -(*lemma spm_linprog_dual_estimate_1:
22.1052 - assumes
22.1053 - "sorted_sparse_matrix A1"
22.1054 - "sorted_sparse_matrix A2"
22.1055 - "sorted_sparse_matrix c1"
22.1056 - "sorted_sparse_matrix c2"
22.1057 - "sorted_sparse_matrix y"
22.1058 - "sorted_spvec b"
22.1059 - "sorted_spvec r"
22.1060 - "le_spmat ([], y)"
22.1061 - "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
22.1062 - "sparse_row_matrix A1 <= A"
22.1063 - "A <= sparse_row_matrix A2"
22.1064 - "sparse_row_matrix c1 <= c"
22.1065 - "c <= sparse_row_matrix c2"
22.1066 - "abs x \<le> sparse_row_matrix r"
22.1067 - shows
22.1068 - "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b, mult_spmat (add_spmat (add_spmat (mult_spmat y (diff_spmat A2 A1),
22.1069 - abs_spmat (diff_spmat (mult_spmat y A1) c1)), diff_spmat c2 c1)) r))"
22.1070 - by (insert prems, simp add: sparse_row_matrix_op_simps linprog_dual_estimate_1[where A=A])
22.1071 -*)
22.1072 -
22.1073 -end
23.1 --- a/src/HOL/Matrix/document/root.tex Sat Mar 17 12:26:19 2012 +0100
23.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3 @@ -1,25 +0,0 @@
23.4 -\documentclass[11pt,a4paper]{article}
23.5 -\usepackage{isabelle,isabellesym}
23.6 -
23.7 -% this should be the last package used
23.8 -\usepackage{pdfsetup}
23.9 -
23.10 -% urls in roman style, theory text in math-similar italics
23.11 -\urlstyle{rm}
23.12 -\isabellestyle{it}
23.13 -
23.14 -\newcommand{\ganz}{\mathsf{Z}\mkern-7.5mu\mathsf{Z}}
23.15 -
23.16 -\begin{document}
23.17 -
23.18 -\title{Matrix}
23.19 -\author{Steven Obua}
23.20 -\maketitle
23.21 -
23.22 -%\tableofcontents
23.23 -
23.24 -\parindent 0pt\parskip 0.5ex
23.25 -
23.26 -\input{session}
23.27 -
23.28 -\end{document}
24.1 --- a/src/HOL/Matrix/fspmlp.ML Sat Mar 17 12:26:19 2012 +0100
24.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
24.3 @@ -1,313 +0,0 @@
24.4 -(* Title: HOL/Matrix/fspmlp.ML
24.5 - Author: Steven Obua
24.6 -*)
24.7 -
24.8 -signature FSPMLP =
24.9 -sig
24.10 - type linprog
24.11 - type vector = FloatSparseMatrixBuilder.vector
24.12 - type matrix = FloatSparseMatrixBuilder.matrix
24.13 -
24.14 - val y : linprog -> term
24.15 - val A : linprog -> term * term
24.16 - val b : linprog -> term
24.17 - val c : linprog -> term * term
24.18 - val r12 : linprog -> term * term
24.19 -
24.20 - exception Load of string
24.21 -
24.22 - val load : string -> int -> bool -> linprog
24.23 -end
24.24 -
24.25 -structure Fspmlp : FSPMLP =
24.26 -struct
24.27 -
24.28 -type vector = FloatSparseMatrixBuilder.vector
24.29 -type matrix = FloatSparseMatrixBuilder.matrix
24.30 -
24.31 -type linprog = term * (term * term) * term * (term * term) * (term * term)
24.32 -
24.33 -fun y (c1, _, _, _, _) = c1
24.34 -fun A (_, c2, _, _, _) = c2
24.35 -fun b (_, _, c3, _, _) = c3
24.36 -fun c (_, _, _, c4, _) = c4
24.37 -fun r12 (_, _, _, _, c6) = c6
24.38 -
24.39 -structure CplexFloatSparseMatrixConverter =
24.40 -MAKE_CPLEX_MATRIX_CONVERTER(structure cplex = Cplex and matrix_builder = FloatSparseMatrixBuilder);
24.41 -
24.42 -datatype bound_type = LOWER | UPPER
24.43 -
24.44 -fun intbound_ord ((i1: int, b1),(i2,b2)) =
24.45 - if i1 < i2 then LESS
24.46 - else if i1 = i2 then
24.47 - (if b1 = b2 then EQUAL else if b1=LOWER then LESS else GREATER)
24.48 - else GREATER
24.49 -
24.50 -structure Inttab = Table(type key = int val ord = (rev_order o int_ord));
24.51 -
24.52 -structure VarGraph = Table(type key = int*bound_type val ord = intbound_ord);
24.53 -(* key -> (float option) * (int -> (float * (((float * float) * key) list)))) *)
24.54 -(* dest_key -> (sure_bound * (row_index -> (row_bound * (((coeff_lower * coeff_upper) * src_key) list)))) *)
24.55 -
24.56 -exception Internal of string;
24.57 -
24.58 -fun add_row_bound g dest_key row_index row_bound =
24.59 - let
24.60 - val x =
24.61 - case VarGraph.lookup g dest_key of
24.62 - NONE => (NONE, Inttab.update (row_index, (row_bound, [])) Inttab.empty)
24.63 - | SOME (sure_bound, f) =>
24.64 - (sure_bound,
24.65 - case Inttab.lookup f row_index of
24.66 - NONE => Inttab.update (row_index, (row_bound, [])) f
24.67 - | SOME _ => raise (Internal "add_row_bound"))
24.68 - in
24.69 - VarGraph.update (dest_key, x) g
24.70 - end
24.71 -
24.72 -fun update_sure_bound g (key as (_, btype)) bound =
24.73 - let
24.74 - val x =
24.75 - case VarGraph.lookup g key of
24.76 - NONE => (SOME bound, Inttab.empty)
24.77 - | SOME (NONE, f) => (SOME bound, f)
24.78 - | SOME (SOME old_bound, f) =>
24.79 - (SOME ((case btype of
24.80 - UPPER => Float.min
24.81 - | LOWER => Float.max)
24.82 - old_bound bound), f)
24.83 - in
24.84 - VarGraph.update (key, x) g
24.85 - end
24.86 -
24.87 -fun get_sure_bound g key =
24.88 - case VarGraph.lookup g key of
24.89 - NONE => NONE
24.90 - | SOME (sure_bound, _) => sure_bound
24.91 -
24.92 -(*fun get_row_bound g key row_index =
24.93 - case VarGraph.lookup g key of
24.94 - NONE => NONE
24.95 - | SOME (sure_bound, f) =>
24.96 - (case Inttab.lookup f row_index of
24.97 - NONE => NONE
24.98 - | SOME (row_bound, _) => (sure_bound, row_bound))*)
24.99 -
24.100 -fun add_edge g src_key dest_key row_index coeff =
24.101 - case VarGraph.lookup g dest_key of
24.102 - NONE => raise (Internal "add_edge: dest_key not found")
24.103 - | SOME (sure_bound, f) =>
24.104 - (case Inttab.lookup f row_index of
24.105 - NONE => raise (Internal "add_edge: row_index not found")
24.106 - | SOME (row_bound, sources) =>
24.107 - VarGraph.update (dest_key, (sure_bound, Inttab.update (row_index, (row_bound, (coeff, src_key) :: sources)) f)) g)
24.108 -
24.109 -fun split_graph g =
24.110 - let
24.111 - fun split (key, (sure_bound, _)) (r1, r2) = case sure_bound
24.112 - of NONE => (r1, r2)
24.113 - | SOME bound => (case key
24.114 - of (u, UPPER) => (r1, Inttab.update (u, bound) r2)
24.115 - | (u, LOWER) => (Inttab.update (u, bound) r1, r2))
24.116 - in VarGraph.fold split g (Inttab.empty, Inttab.empty) end
24.117 -
24.118 -(* If safe is true, termination is guaranteed, but the sure bounds may be not optimal (relative to the algorithm).
24.119 - If safe is false, termination is not guaranteed, but on termination the sure bounds are optimal (relative to the algorithm) *)
24.120 -fun propagate_sure_bounds safe names g =
24.121 - let
24.122 - (* returns NONE if no new sure bound could be calculated, otherwise the new sure bound is returned *)
24.123 - fun calc_sure_bound_from_sources g (key as (_, btype)) =
24.124 - let
24.125 - fun mult_upper x (lower, upper) =
24.126 - if Float.sign x = LESS then
24.127 - Float.mult x lower
24.128 - else
24.129 - Float.mult x upper
24.130 -
24.131 - fun mult_lower x (lower, upper) =
24.132 - if Float.sign x = LESS then
24.133 - Float.mult x upper
24.134 - else
24.135 - Float.mult x lower
24.136 -
24.137 - val mult_btype = case btype of UPPER => mult_upper | LOWER => mult_lower
24.138 -
24.139 - fun calc_sure_bound (_, (row_bound, sources)) sure_bound =
24.140 - let
24.141 - fun add_src_bound (coeff, src_key) sum =
24.142 - case sum of
24.143 - NONE => NONE
24.144 - | SOME x =>
24.145 - (case get_sure_bound g src_key of
24.146 - NONE => NONE
24.147 - | SOME src_sure_bound => SOME (Float.add x (mult_btype src_sure_bound coeff)))
24.148 - in
24.149 - case fold add_src_bound sources (SOME row_bound) of
24.150 - NONE => sure_bound
24.151 - | new_sure_bound as (SOME new_bound) =>
24.152 - (case sure_bound of
24.153 - NONE => new_sure_bound
24.154 - | SOME old_bound =>
24.155 - SOME (case btype of
24.156 - UPPER => Float.min old_bound new_bound
24.157 - | LOWER => Float.max old_bound new_bound))
24.158 - end
24.159 - in
24.160 - case VarGraph.lookup g key of
24.161 - NONE => NONE
24.162 - | SOME (sure_bound, f) =>
24.163 - let
24.164 - val x = Inttab.fold calc_sure_bound f sure_bound
24.165 - in
24.166 - if x = sure_bound then NONE else x
24.167 - end
24.168 - end
24.169 -
24.170 - fun propagate (key, _) (g, b) =
24.171 - case calc_sure_bound_from_sources g key of
24.172 - NONE => (g,b)
24.173 - | SOME bound => (update_sure_bound g key bound,
24.174 - if safe then
24.175 - case get_sure_bound g key of
24.176 - NONE => true
24.177 - | _ => b
24.178 - else
24.179 - true)
24.180 -
24.181 - val (g, b) = VarGraph.fold propagate g (g, false)
24.182 - in
24.183 - if b then propagate_sure_bounds safe names g else g
24.184 - end
24.185 -
24.186 -exception Load of string;
24.187 -
24.188 -val empty_spvec = @{term "Nil :: real spvec"};
24.189 -fun cons_spvec x xs = @{term "Cons :: nat * real => real spvec => real spvec"} $ x $ xs;
24.190 -val empty_spmat = @{term "Nil :: real spmat"};
24.191 -fun cons_spmat x xs = @{term "Cons :: nat * real spvec => real spmat => real spmat"} $ x $ xs;
24.192 -
24.193 -fun calcr safe_propagation xlen names prec A b =
24.194 - let
24.195 - fun test_1 (lower, upper) =
24.196 - if lower = upper then
24.197 - (if Float.eq (lower, (~1, 0)) then ~1
24.198 - else if Float.eq (lower, (1, 0)) then 1
24.199 - else 0)
24.200 - else 0
24.201 -
24.202 - fun calcr (row_index, a) g =
24.203 - let
24.204 - val b = FloatSparseMatrixBuilder.v_elem_at b row_index
24.205 - val (_, b2) = FloatArith.approx_decstr_by_bin prec (case b of NONE => "0" | SOME b => b)
24.206 - val approx_a = FloatSparseMatrixBuilder.v_fold (fn (i, s) => fn l =>
24.207 - (i, FloatArith.approx_decstr_by_bin prec s)::l) a []
24.208 -
24.209 - fun fold_dest_nodes (dest_index, dest_value) g =
24.210 - let
24.211 - val dest_test = test_1 dest_value
24.212 - in
24.213 - if dest_test = 0 then
24.214 - g
24.215 - else let
24.216 - val (dest_key as (_, dest_btype), row_bound) =
24.217 - if dest_test = ~1 then
24.218 - ((dest_index, LOWER), Float.neg b2)
24.219 - else
24.220 - ((dest_index, UPPER), b2)
24.221 -
24.222 - fun fold_src_nodes (src_index, src_value as (src_lower, src_upper)) g =
24.223 - if src_index = dest_index then g
24.224 - else
24.225 - let
24.226 - val coeff = case dest_btype of
24.227 - UPPER => (Float.neg src_upper, Float.neg src_lower)
24.228 - | LOWER => src_value
24.229 - in
24.230 - if Float.sign src_lower = LESS then
24.231 - add_edge g (src_index, UPPER) dest_key row_index coeff
24.232 - else
24.233 - add_edge g (src_index, LOWER) dest_key row_index coeff
24.234 - end
24.235 - in
24.236 - fold fold_src_nodes approx_a (add_row_bound g dest_key row_index row_bound)
24.237 - end
24.238 - end
24.239 - in
24.240 - case approx_a of
24.241 - [] => g
24.242 - | [(u, a)] =>
24.243 - let
24.244 - val atest = test_1 a
24.245 - in
24.246 - if atest = ~1 then
24.247 - update_sure_bound g (u, LOWER) (Float.neg b2)
24.248 - else if atest = 1 then
24.249 - update_sure_bound g (u, UPPER) b2
24.250 - else
24.251 - g
24.252 - end
24.253 - | _ => fold fold_dest_nodes approx_a g
24.254 - end
24.255 -
24.256 - val g = FloatSparseMatrixBuilder.m_fold calcr A VarGraph.empty
24.257 -
24.258 - val g = propagate_sure_bounds safe_propagation names g
24.259 -
24.260 - val (r1, r2) = split_graph g
24.261 -
24.262 - fun add_row_entry m index f vname value =
24.263 - let
24.264 - val v = (case value of
24.265 - SOME value => FloatSparseMatrixBuilder.mk_spvec_entry 0 value
24.266 - | NONE => FloatSparseMatrixBuilder.mk_spvec_entry' 0 (f $ (Var ((vname,0), HOLogic.realT))))
24.267 - val vec = cons_spvec v empty_spvec
24.268 - in
24.269 - cons_spmat (FloatSparseMatrixBuilder.mk_spmat_entry index vec) m
24.270 - end
24.271 -
24.272 - fun abs_estimate i r1 r2 =
24.273 - if i = 0 then
24.274 - let val e = empty_spmat in (e, e) end
24.275 - else
24.276 - let
24.277 - val index = xlen-i
24.278 - val (r12_1, r12_2) = abs_estimate (i-1) r1 r2
24.279 - val b1 = Inttab.lookup r1 index
24.280 - val b2 = Inttab.lookup r2 index
24.281 - in
24.282 - (add_row_entry r12_1 index @{term "lbound :: real => real"} ((names index)^"l") b1,
24.283 - add_row_entry r12_2 index @{term "ubound :: real => real"} ((names index)^"u") b2)
24.284 - end
24.285 -
24.286 - val (r1, r2) = abs_estimate xlen r1 r2
24.287 -
24.288 - in
24.289 - (r1, r2)
24.290 - end
24.291 -
24.292 -fun load filename prec safe_propagation =
24.293 - let
24.294 - val prog = Cplex.load_cplexFile filename
24.295 - val prog = Cplex.elim_nonfree_bounds prog
24.296 - val prog = Cplex.relax_strict_ineqs prog
24.297 - val (maximize, c, A, b, (xlen, names, _)) = CplexFloatSparseMatrixConverter.convert_prog prog
24.298 - val (r1, r2) = calcr safe_propagation xlen names prec A b
24.299 - val _ = if maximize then () else raise Load "sorry, cannot handle minimization problems"
24.300 - val (dualprog, indexof) = FloatSparseMatrixBuilder.dual_cplexProg c A b
24.301 - val results = Cplex.solve dualprog
24.302 - val (_, v) = CplexFloatSparseMatrixConverter.convert_results results indexof
24.303 - (*val A = FloatSparseMatrixBuilder.cut_matrix v NONE A*)
24.304 - fun id x = x
24.305 - val v = FloatSparseMatrixBuilder.set_vector FloatSparseMatrixBuilder.empty_matrix 0 v
24.306 - val b = FloatSparseMatrixBuilder.transpose_matrix (FloatSparseMatrixBuilder.set_vector FloatSparseMatrixBuilder.empty_matrix 0 b)
24.307 - val c = FloatSparseMatrixBuilder.set_vector FloatSparseMatrixBuilder.empty_matrix 0 c
24.308 - val (y1, _) = FloatSparseMatrixBuilder.approx_matrix prec Float.positive_part v
24.309 - val A = FloatSparseMatrixBuilder.approx_matrix prec id A
24.310 - val (_,b2) = FloatSparseMatrixBuilder.approx_matrix prec id b
24.311 - val c = FloatSparseMatrixBuilder.approx_matrix prec id c
24.312 - in
24.313 - (y1, A, b2, c, (r1, r2))
24.314 - end handle CplexFloatSparseMatrixConverter.Converter s => (raise (Load ("Converter: "^s)))
24.315 -
24.316 -end
25.1 --- a/src/HOL/Matrix/matrixlp.ML Sat Mar 17 12:26:19 2012 +0100
25.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
25.3 @@ -1,59 +0,0 @@
25.4 -(* Title: HOL/Matrix/matrixlp.ML
25.5 - Author: Steven Obua
25.6 -*)
25.7 -
25.8 -signature MATRIX_LP =
25.9 -sig
25.10 - val matrix_compute : cterm -> thm
25.11 - val matrix_simplify : thm -> thm
25.12 - val prove_bound : string -> int -> thm
25.13 - val float2real : string * string -> Real.real
25.14 -end
25.15 -
25.16 -structure MatrixLP : MATRIX_LP =
25.17 -struct
25.18 -
25.19 -val compute_thms = ComputeHOL.prep_thms @{thms "ComputeHOL.compute_list_case" "ComputeHOL.compute_let"
25.20 - "ComputeHOL.compute_if" "ComputeFloat.arith" "SparseMatrix.sparse_row_matrix_arith_simps"
25.21 - "ComputeHOL.compute_bool" "ComputeHOL.compute_pair"
25.22 - "SparseMatrix.sorted_sp_simps"
25.23 - "ComputeNumeral.natnorm"}; (*"ComputeNumeral.number_norm"*)
25.24 -
25.25 -val spm_mult_le_dual_prts_no_let_real = @{thm "spm_mult_le_dual_prts_no_let" [where ?'a = real]}
25.26 -
25.27 -fun lp_dual_estimate_prt lptfile prec =
25.28 - let
25.29 - val cert = cterm_of @{theory}
25.30 - fun var s x = (cert (Var ((s, 0), FloatSparseMatrixBuilder.spmatT)), x)
25.31 - val l = Fspmlp.load lptfile prec false
25.32 - val (y, (A1, A2), (c1, c2), b, (r1, r2)) =
25.33 - let
25.34 - open Fspmlp
25.35 - in
25.36 - (y l |> cert, A l |> pairself cert, c l |> pairself cert, b l |> cert, r12 l |> pairself cert)
25.37 - end
25.38 - in
25.39 - Thm.instantiate ([],
25.40 - [var "A1" A1, var "A2" A2, var "y" y, var "c1" c1, var "c2" c2, var "r1" r1, var "r2" r2, var "b" b])
25.41 - spm_mult_le_dual_prts_no_let_real
25.42 - end
25.43 -
25.44 -val computer = PCompute.make Compute.SML @{theory} compute_thms []
25.45 -
25.46 -fun matrix_compute c = hd (PCompute.rewrite computer [c])
25.47 -
25.48 -fun matrix_simplify th =
25.49 - let
25.50 - val simp_th = matrix_compute (cprop_of th)
25.51 - val th = Thm.strip_shyps (Thm.equal_elim simp_th th)
25.52 - fun removeTrue th = removeTrue (Thm.implies_elim th TrueI) handle THM _ => th
25.53 - in
25.54 - removeTrue th
25.55 - end
25.56 -
25.57 -val prove_bound = matrix_simplify oo lp_dual_estimate_prt;
25.58 -
25.59 -val realFromStr = the o Real.fromString;
25.60 -fun float2real (x, y) = realFromStr x * Math.pow (2.0, realFromStr y);
25.61 -
25.62 -end
26.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
26.2 +++ b/src/HOL/Matrix_LP/ComputeFloat.thy Sat Mar 17 12:52:40 2012 +0100
26.3 @@ -0,0 +1,309 @@
26.4 +(* Title: HOL/Matrix/ComputeFloat.thy
26.5 + Author: Steven Obua
26.6 +*)
26.7 +
26.8 +header {* Floating Point Representation of the Reals *}
26.9 +
26.10 +theory ComputeFloat
26.11 +imports Complex_Main "~~/src/HOL/Library/Lattice_Algebras"
26.12 +uses "~~/src/Tools/float.ML" ("~~/src/HOL/Tools/float_arith.ML")
26.13 +begin
26.14 +
26.15 +definition int_of_real :: "real \<Rightarrow> int"
26.16 + where "int_of_real x = (SOME y. real y = x)"
26.17 +
26.18 +definition real_is_int :: "real \<Rightarrow> bool"
26.19 + where "real_is_int x = (EX (u::int). x = real u)"
26.20 +
26.21 +lemma real_is_int_def2: "real_is_int x = (x = real (int_of_real x))"
26.22 + by (auto simp add: real_is_int_def int_of_real_def)
26.23 +
26.24 +lemma real_is_int_real[simp]: "real_is_int (real (x::int))"
26.25 +by (auto simp add: real_is_int_def int_of_real_def)
26.26 +
26.27 +lemma int_of_real_real[simp]: "int_of_real (real x) = x"
26.28 +by (simp add: int_of_real_def)
26.29 +
26.30 +lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real (int_of_real x) = x"
26.31 +by (auto simp add: int_of_real_def real_is_int_def)
26.32 +
26.33 +lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
26.34 +by (auto simp add: int_of_real_def real_is_int_def)
26.35 +
26.36 +lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
26.37 +apply (subst real_is_int_def2)
26.38 +apply (simp add: real_is_int_add_int_of_real real_int_of_real)
26.39 +done
26.40 +
26.41 +lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
26.42 +by (auto simp add: int_of_real_def real_is_int_def)
26.43 +
26.44 +lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
26.45 +apply (subst real_is_int_def2)
26.46 +apply (simp add: int_of_real_sub real_int_of_real)
26.47 +done
26.48 +
26.49 +lemma real_is_int_rep: "real_is_int x \<Longrightarrow> ?! (a::int). real a = x"
26.50 +by (auto simp add: real_is_int_def)
26.51 +
26.52 +lemma int_of_real_mult:
26.53 + assumes "real_is_int a" "real_is_int b"
26.54 + shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
26.55 + using assms
26.56 + by (auto simp add: real_is_int_def real_of_int_mult[symmetric]
26.57 + simp del: real_of_int_mult)
26.58 +
26.59 +lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
26.60 +apply (subst real_is_int_def2)
26.61 +apply (simp add: int_of_real_mult)
26.62 +done
26.63 +
26.64 +lemma real_is_int_0[simp]: "real_is_int (0::real)"
26.65 +by (simp add: real_is_int_def int_of_real_def)
26.66 +
26.67 +lemma real_is_int_1[simp]: "real_is_int (1::real)"
26.68 +proof -
26.69 + have "real_is_int (1::real) = real_is_int(real (1::int))" by auto
26.70 + also have "\<dots> = True" by (simp only: real_is_int_real)
26.71 + ultimately show ?thesis by auto
26.72 +qed
26.73 +
26.74 +lemma real_is_int_n1: "real_is_int (-1::real)"
26.75 +proof -
26.76 + have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
26.77 + also have "\<dots> = True" by (simp only: real_is_int_real)
26.78 + ultimately show ?thesis by auto
26.79 +qed
26.80 +
26.81 +lemma real_is_int_number_of[simp]: "real_is_int ((number_of \<Colon> int \<Rightarrow> real) x)"
26.82 + by (auto simp: real_is_int_def intro!: exI[of _ "number_of x"])
26.83 +
26.84 +lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
26.85 +by (simp add: int_of_real_def)
26.86 +
26.87 +lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
26.88 +proof -
26.89 + have 1: "(1::real) = real (1::int)" by auto
26.90 + show ?thesis by (simp only: 1 int_of_real_real)
26.91 +qed
26.92 +
26.93 +lemma int_of_real_number_of[simp]: "int_of_real (number_of b) = number_of b"
26.94 + unfolding int_of_real_def
26.95 + by (intro some_equality)
26.96 + (auto simp add: real_of_int_inject[symmetric] simp del: real_of_int_inject)
26.97 +
26.98 +lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
26.99 +by (rule zdiv_int)
26.100 +
26.101 +lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
26.102 +by (rule zmod_int)
26.103 +
26.104 +lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> abs((a::int) div 2) < abs a"
26.105 +by arith
26.106 +
26.107 +lemma norm_0_1: "(0::_::number_ring) = Numeral0 & (1::_::number_ring) = Numeral1"
26.108 + by auto
26.109 +
26.110 +lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
26.111 + by simp
26.112 +
26.113 +lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
26.114 + by simp
26.115 +
26.116 +lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
26.117 + by simp
26.118 +
26.119 +lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
26.120 + by simp
26.121 +
26.122 +lemma int_pow_0: "(a::int)^(Numeral0) = 1"
26.123 + by simp
26.124 +
26.125 +lemma int_pow_1: "(a::int)^(Numeral1) = a"
26.126 + by simp
26.127 +
26.128 +lemma zero_eq_Numeral0_nring: "(0::'a::number_ring) = Numeral0"
26.129 + by simp
26.130 +
26.131 +lemma one_eq_Numeral1_nring: "(1::'a::number_ring) = Numeral1"
26.132 + by simp
26.133 +
26.134 +lemma zero_eq_Numeral0_nat: "(0::nat) = Numeral0"
26.135 + by simp
26.136 +
26.137 +lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
26.138 + by simp
26.139 +
26.140 +lemma zpower_Pls: "(z::int)^Numeral0 = Numeral1"
26.141 + by simp
26.142 +
26.143 +lemma zpower_Min: "(z::int)^((-1)::nat) = Numeral1"
26.144 +proof -
26.145 + have 1:"((-1)::nat) = 0"
26.146 + by simp
26.147 + show ?thesis by (simp add: 1)
26.148 +qed
26.149 +
26.150 +lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
26.151 + by simp
26.152 +
26.153 +lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
26.154 + by simp
26.155 +
26.156 +lemma lift_bool: "x \<Longrightarrow> x=True"
26.157 + by simp
26.158 +
26.159 +lemma nlift_bool: "~x \<Longrightarrow> x=False"
26.160 + by simp
26.161 +
26.162 +lemma not_false_eq_true: "(~ False) = True" by simp
26.163 +
26.164 +lemma not_true_eq_false: "(~ True) = False" by simp
26.165 +
26.166 +lemmas binarith =
26.167 + normalize_bin_simps
26.168 + pred_bin_simps succ_bin_simps
26.169 + add_bin_simps minus_bin_simps mult_bin_simps
26.170 +
26.171 +lemma int_eq_number_of_eq:
26.172 + "(((number_of v)::int)=(number_of w)) = iszero ((number_of (v + uminus w))::int)"
26.173 + by (rule eq_number_of_eq)
26.174 +
26.175 +lemma int_iszero_number_of_Pls: "iszero (Numeral0::int)"
26.176 + by (simp only: iszero_number_of_Pls)
26.177 +
26.178 +lemma int_nonzero_number_of_Min: "~(iszero ((-1)::int))"
26.179 + by simp
26.180 +
26.181 +lemma int_iszero_number_of_Bit0: "iszero ((number_of (Int.Bit0 w))::int) = iszero ((number_of w)::int)"
26.182 + by simp
26.183 +
26.184 +lemma int_iszero_number_of_Bit1: "\<not> iszero ((number_of (Int.Bit1 w))::int)"
26.185 + by simp
26.186 +
26.187 +lemma int_less_number_of_eq_neg: "(((number_of x)::int) < number_of y) = neg ((number_of (x + (uminus y)))::int)"
26.188 + unfolding neg_def number_of_is_id by simp
26.189 +
26.190 +lemma int_not_neg_number_of_Pls: "\<not> (neg (Numeral0::int))"
26.191 + by simp
26.192 +
26.193 +lemma int_neg_number_of_Min: "neg (-1::int)"
26.194 + by simp
26.195 +
26.196 +lemma int_neg_number_of_Bit0: "neg ((number_of (Int.Bit0 w))::int) = neg ((number_of w)::int)"
26.197 + by simp
26.198 +
26.199 +lemma int_neg_number_of_Bit1: "neg ((number_of (Int.Bit1 w))::int) = neg ((number_of w)::int)"
26.200 + by simp
26.201 +
26.202 +lemma int_le_number_of_eq: "(((number_of x)::int) \<le> number_of y) = (\<not> neg ((number_of (y + (uminus x)))::int))"
26.203 + unfolding neg_def number_of_is_id by (simp add: not_less)
26.204 +
26.205 +lemmas intarithrel =
26.206 + int_eq_number_of_eq
26.207 + lift_bool[OF int_iszero_number_of_Pls] nlift_bool[OF int_nonzero_number_of_Min] int_iszero_number_of_Bit0
26.208 + lift_bool[OF int_iszero_number_of_Bit1] int_less_number_of_eq_neg nlift_bool[OF int_not_neg_number_of_Pls] lift_bool[OF int_neg_number_of_Min]
26.209 + int_neg_number_of_Bit0 int_neg_number_of_Bit1 int_le_number_of_eq
26.210 +
26.211 +lemma int_number_of_add_sym: "((number_of v)::int) + number_of w = number_of (v + w)"
26.212 + by simp
26.213 +
26.214 +lemma int_number_of_diff_sym: "((number_of v)::int) - number_of w = number_of (v + (uminus w))"
26.215 + by simp
26.216 +
26.217 +lemma int_number_of_mult_sym: "((number_of v)::int) * number_of w = number_of (v * w)"
26.218 + by simp
26.219 +
26.220 +lemma int_number_of_minus_sym: "- ((number_of v)::int) = number_of (uminus v)"
26.221 + by simp
26.222 +
26.223 +lemmas intarith = int_number_of_add_sym int_number_of_minus_sym int_number_of_diff_sym int_number_of_mult_sym
26.224 +
26.225 +lemmas natarith = add_nat_number_of diff_nat_number_of mult_nat_number_of eq_nat_number_of less_nat_number_of
26.226 +
26.227 +lemmas powerarith = nat_number_of zpower_number_of_even
26.228 + zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
26.229 + zpower_Pls zpower_Min
26.230 +
26.231 +definition float :: "(int \<times> int) \<Rightarrow> real" where
26.232 + "float = (\<lambda>(a, b). real a * 2 powr real b)"
26.233 +
26.234 +lemma float_add_l0: "float (0, e) + x = x"
26.235 + by (simp add: float_def)
26.236 +
26.237 +lemma float_add_r0: "x + float (0, e) = x"
26.238 + by (simp add: float_def)
26.239 +
26.240 +lemma float_add:
26.241 + "float (a1, e1) + float (a2, e2) =
26.242 + (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1) else float (a1*2^(nat (e1-e2))+a2, e2))"
26.243 + by (simp add: float_def algebra_simps powr_realpow[symmetric] powr_divide2[symmetric])
26.244 +
26.245 +lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
26.246 + by (simp add: float_def)
26.247 +
26.248 +lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
26.249 + by (simp add: float_def)
26.250 +
26.251 +lemma float_mult:
26.252 + "float (a1, e1) * float (a2, e2) = (float (a1 * a2, e1 + e2))"
26.253 + by (simp add: float_def powr_add)
26.254 +
26.255 +lemma float_minus:
26.256 + "- (float (a,b)) = float (-a, b)"
26.257 + by (simp add: float_def)
26.258 +
26.259 +lemma zero_le_float:
26.260 + "(0 <= float (a,b)) = (0 <= a)"
26.261 + using powr_gt_zero[of 2 "real b", arith]
26.262 + by (simp add: float_def zero_le_mult_iff)
26.263 +
26.264 +lemma float_le_zero:
26.265 + "(float (a,b) <= 0) = (a <= 0)"
26.266 + using powr_gt_zero[of 2 "real b", arith]
26.267 + by (simp add: float_def mult_le_0_iff)
26.268 +
26.269 +lemma float_abs:
26.270 + "abs (float (a,b)) = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
26.271 + using powr_gt_zero[of 2 "real b", arith]
26.272 + by (simp add: float_def abs_if mult_less_0_iff)
26.273 +
26.274 +lemma float_zero:
26.275 + "float (0, b) = 0"
26.276 + by (simp add: float_def)
26.277 +
26.278 +lemma float_pprt:
26.279 + "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
26.280 + by (auto simp add: zero_le_float float_le_zero float_zero)
26.281 +
26.282 +lemma float_nprt:
26.283 + "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
26.284 + by (auto simp add: zero_le_float float_le_zero float_zero)
26.285 +
26.286 +definition lbound :: "real \<Rightarrow> real"
26.287 + where "lbound x = min 0 x"
26.288 +
26.289 +definition ubound :: "real \<Rightarrow> real"
26.290 + where "ubound x = max 0 x"
26.291 +
26.292 +lemma lbound: "lbound x \<le> x"
26.293 + by (simp add: lbound_def)
26.294 +
26.295 +lemma ubound: "x \<le> ubound x"
26.296 + by (simp add: ubound_def)
26.297 +
26.298 +lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
26.299 + by (auto simp: float_def lbound_def)
26.300 +
26.301 +lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
26.302 + by (auto simp: float_def ubound_def)
26.303 +
26.304 +lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
26.305 + float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound
26.306 +
26.307 +(* for use with the compute oracle *)
26.308 +lemmas arith = binarith intarith intarithrel natarith powerarith floatarith not_false_eq_true not_true_eq_false
26.309 +
26.310 +use "~~/src/HOL/Tools/float_arith.ML"
26.311 +
26.312 +end
27.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
27.2 +++ b/src/HOL/Matrix_LP/ComputeHOL.thy Sat Mar 17 12:52:40 2012 +0100
27.3 @@ -0,0 +1,187 @@
27.4 +theory ComputeHOL
27.5 +imports Complex_Main "Compute_Oracle/Compute_Oracle"
27.6 +begin
27.7 +
27.8 +lemma Trueprop_eq_eq: "Trueprop X == (X == True)" by (simp add: atomize_eq)
27.9 +lemma meta_eq_trivial: "x == y \<Longrightarrow> x == y" by simp
27.10 +lemma meta_eq_imp_eq: "x == y \<Longrightarrow> x = y" by auto
27.11 +lemma eq_trivial: "x = y \<Longrightarrow> x = y" by auto
27.12 +lemma bool_to_true: "x :: bool \<Longrightarrow> x == True" by simp
27.13 +lemma transmeta_1: "x = y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
27.14 +lemma transmeta_2: "x == y \<Longrightarrow> y = z \<Longrightarrow> x = z" by simp
27.15 +lemma transmeta_3: "x == y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
27.16 +
27.17 +
27.18 +(**** compute_if ****)
27.19 +
27.20 +lemma If_True: "If True = (\<lambda> x y. x)" by ((rule ext)+,auto)
27.21 +lemma If_False: "If False = (\<lambda> x y. y)" by ((rule ext)+, auto)
27.22 +
27.23 +lemmas compute_if = If_True If_False
27.24 +
27.25 +(**** compute_bool ****)
27.26 +
27.27 +lemma bool1: "(\<not> True) = False" by blast
27.28 +lemma bool2: "(\<not> False) = True" by blast
27.29 +lemma bool3: "(P \<and> True) = P" by blast
27.30 +lemma bool4: "(True \<and> P) = P" by blast
27.31 +lemma bool5: "(P \<and> False) = False" by blast
27.32 +lemma bool6: "(False \<and> P) = False" by blast
27.33 +lemma bool7: "(P \<or> True) = True" by blast
27.34 +lemma bool8: "(True \<or> P) = True" by blast
27.35 +lemma bool9: "(P \<or> False) = P" by blast
27.36 +lemma bool10: "(False \<or> P) = P" by blast
27.37 +lemma bool11: "(True \<longrightarrow> P) = P" by blast
27.38 +lemma bool12: "(P \<longrightarrow> True) = True" by blast
27.39 +lemma bool13: "(True \<longrightarrow> P) = P" by blast
27.40 +lemma bool14: "(P \<longrightarrow> False) = (\<not> P)" by blast
27.41 +lemma bool15: "(False \<longrightarrow> P) = True" by blast
27.42 +lemma bool16: "(False = False) = True" by blast
27.43 +lemma bool17: "(True = True) = True" by blast
27.44 +lemma bool18: "(False = True) = False" by blast
27.45 +lemma bool19: "(True = False) = False" by blast
27.46 +
27.47 +lemmas compute_bool = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10 bool11 bool12 bool13 bool14 bool15 bool16 bool17 bool18 bool19
27.48 +
27.49 +
27.50 +(*** compute_pair ***)
27.51 +
27.52 +lemma compute_fst: "fst (x,y) = x" by simp
27.53 +lemma compute_snd: "snd (x,y) = y" by simp
27.54 +lemma compute_pair_eq: "((a, b) = (c, d)) = (a = c \<and> b = d)" by auto
27.55 +
27.56 +lemma prod_case_simp: "prod_case f (x,y) = f x y" by simp
27.57 +
27.58 +lemmas compute_pair = compute_fst compute_snd compute_pair_eq prod_case_simp
27.59 +
27.60 +(*** compute_option ***)
27.61 +
27.62 +lemma compute_the: "the (Some x) = x" by simp
27.63 +lemma compute_None_Some_eq: "(None = Some x) = False" by auto
27.64 +lemma compute_Some_None_eq: "(Some x = None) = False" by auto
27.65 +lemma compute_None_None_eq: "(None = None) = True" by auto
27.66 +lemma compute_Some_Some_eq: "(Some x = Some y) = (x = y)" by auto
27.67 +
27.68 +definition option_case_compute :: "'b option \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a"
27.69 + where "option_case_compute opt a f = option_case a f opt"
27.70 +
27.71 +lemma option_case_compute: "option_case = (\<lambda> a f opt. option_case_compute opt a f)"
27.72 + by (simp add: option_case_compute_def)
27.73 +
27.74 +lemma option_case_compute_None: "option_case_compute None = (\<lambda> a f. a)"
27.75 + apply (rule ext)+
27.76 + apply (simp add: option_case_compute_def)
27.77 + done
27.78 +
27.79 +lemma option_case_compute_Some: "option_case_compute (Some x) = (\<lambda> a f. f x)"
27.80 + apply (rule ext)+
27.81 + apply (simp add: option_case_compute_def)
27.82 + done
27.83 +
27.84 +lemmas compute_option_case = option_case_compute option_case_compute_None option_case_compute_Some
27.85 +
27.86 +lemmas compute_option = compute_the compute_None_Some_eq compute_Some_None_eq compute_None_None_eq compute_Some_Some_eq compute_option_case
27.87 +
27.88 +(**** compute_list_length ****)
27.89 +
27.90 +lemma length_cons:"length (x#xs) = 1 + (length xs)"
27.91 + by simp
27.92 +
27.93 +lemma length_nil: "length [] = 0"
27.94 + by simp
27.95 +
27.96 +lemmas compute_list_length = length_nil length_cons
27.97 +
27.98 +(*** compute_list_case ***)
27.99 +
27.100 +definition list_case_compute :: "'b list \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'a"
27.101 + where "list_case_compute l a f = list_case a f l"
27.102 +
27.103 +lemma list_case_compute: "list_case = (\<lambda> (a::'a) f (l::'b list). list_case_compute l a f)"
27.104 + apply (rule ext)+
27.105 + apply (simp add: list_case_compute_def)
27.106 + done
27.107 +
27.108 +lemma list_case_compute_empty: "list_case_compute ([]::'b list) = (\<lambda> (a::'a) f. a)"
27.109 + apply (rule ext)+
27.110 + apply (simp add: list_case_compute_def)
27.111 + done
27.112 +
27.113 +lemma list_case_compute_cons: "list_case_compute (u#v) = (\<lambda> (a::'a) f. (f (u::'b) v))"
27.114 + apply (rule ext)+
27.115 + apply (simp add: list_case_compute_def)
27.116 + done
27.117 +
27.118 +lemmas compute_list_case = list_case_compute list_case_compute_empty list_case_compute_cons
27.119 +
27.120 +(*** compute_list_nth ***)
27.121 +(* Of course, you will need computation with nats for this to work \<dots> *)
27.122 +
27.123 +lemma compute_list_nth: "((x#xs) ! n) = (if n = 0 then x else (xs ! (n - 1)))"
27.124 + by (cases n, auto)
27.125 +
27.126 +(*** compute_list ***)
27.127 +
27.128 +lemmas compute_list = compute_list_case compute_list_length compute_list_nth
27.129 +
27.130 +(*** compute_let ***)
27.131 +
27.132 +lemmas compute_let = Let_def
27.133 +
27.134 +(***********************)
27.135 +(* Everything together *)
27.136 +(***********************)
27.137 +
27.138 +lemmas compute_hol = compute_if compute_bool compute_pair compute_option compute_list compute_let
27.139 +
27.140 +ML {*
27.141 +signature ComputeHOL =
27.142 +sig
27.143 + val prep_thms : thm list -> thm list
27.144 + val to_meta_eq : thm -> thm
27.145 + val to_hol_eq : thm -> thm
27.146 + val symmetric : thm -> thm
27.147 + val trans : thm -> thm -> thm
27.148 +end
27.149 +
27.150 +structure ComputeHOL : ComputeHOL =
27.151 +struct
27.152 +
27.153 +local
27.154 +fun lhs_of eq = fst (Thm.dest_equals (cprop_of eq));
27.155 +in
27.156 +fun rewrite_conv [] ct = raise CTERM ("rewrite_conv", [ct])
27.157 + | rewrite_conv (eq :: eqs) ct =
27.158 + Thm.instantiate (Thm.match (lhs_of eq, ct)) eq
27.159 + handle Pattern.MATCH => rewrite_conv eqs ct;
27.160 +end
27.161 +
27.162 +val convert_conditions = Conv.fconv_rule (Conv.prems_conv ~1 (Conv.try_conv (rewrite_conv [@{thm "Trueprop_eq_eq"}])))
27.163 +
27.164 +val eq_th = @{thm "HOL.eq_reflection"}
27.165 +val meta_eq_trivial = @{thm "ComputeHOL.meta_eq_trivial"}
27.166 +val bool_to_true = @{thm "ComputeHOL.bool_to_true"}
27.167 +
27.168 +fun to_meta_eq th = eq_th OF [th] handle THM _ => meta_eq_trivial OF [th] handle THM _ => bool_to_true OF [th]
27.169 +
27.170 +fun to_hol_eq th = @{thm "meta_eq_imp_eq"} OF [th] handle THM _ => @{thm "eq_trivial"} OF [th]
27.171 +
27.172 +fun prep_thms ths = map (convert_conditions o to_meta_eq) ths
27.173 +
27.174 +fun symmetric th = @{thm "HOL.sym"} OF [th] handle THM _ => @{thm "Pure.symmetric"} OF [th]
27.175 +
27.176 +local
27.177 + val trans_HOL = @{thm "HOL.trans"}
27.178 + val trans_HOL_1 = @{thm "ComputeHOL.transmeta_1"}
27.179 + val trans_HOL_2 = @{thm "ComputeHOL.transmeta_2"}
27.180 + val trans_HOL_3 = @{thm "ComputeHOL.transmeta_3"}
27.181 + fun tr [] th1 th2 = trans_HOL OF [th1, th2]
27.182 + | tr (t::ts) th1 th2 = (t OF [th1, th2] handle THM _ => tr ts th1 th2)
27.183 +in
27.184 + fun trans th1 th2 = tr [trans_HOL, trans_HOL_1, trans_HOL_2, trans_HOL_3] th1 th2
27.185 +end
27.186 +
27.187 +end
27.188 +*}
27.189 +
27.190 +end
28.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
28.2 +++ b/src/HOL/Matrix_LP/ComputeNumeral.thy Sat Mar 17 12:52:40 2012 +0100
28.3 @@ -0,0 +1,189 @@
28.4 +theory ComputeNumeral
28.5 +imports ComputeHOL ComputeFloat
28.6 +begin
28.7 +
28.8 +(* normalization of bit strings *)
28.9 +lemmas bitnorm = normalize_bin_simps
28.10 +
28.11 +(* neg for bit strings *)
28.12 +lemma neg1: "neg Int.Pls = False" by (simp add: Int.Pls_def)
28.13 +lemma neg2: "neg Int.Min = True" apply (subst Int.Min_def) by auto
28.14 +lemma neg3: "neg (Int.Bit0 x) = neg x" apply (simp add: neg_def) apply (subst Bit0_def) by auto
28.15 +lemma neg4: "neg (Int.Bit1 x) = neg x" apply (simp add: neg_def) apply (subst Bit1_def) by auto
28.16 +lemmas bitneg = neg1 neg2 neg3 neg4
28.17 +
28.18 +(* iszero for bit strings *)
28.19 +lemma iszero1: "iszero Int.Pls = True" by (simp add: Int.Pls_def iszero_def)
28.20 +lemma iszero2: "iszero Int.Min = False" apply (subst Int.Min_def) apply (subst iszero_def) by simp
28.21 +lemma iszero3: "iszero (Int.Bit0 x) = iszero x" apply (subst Int.Bit0_def) apply (subst iszero_def)+ by auto
28.22 +lemma iszero4: "iszero (Int.Bit1 x) = False" apply (subst Int.Bit1_def) apply (subst iszero_def)+ apply simp by arith
28.23 +lemmas bitiszero = iszero1 iszero2 iszero3 iszero4
28.24 +
28.25 +(* lezero for bit strings *)
28.26 +definition "lezero x \<longleftrightarrow> x \<le> 0"
28.27 +lemma lezero1: "lezero Int.Pls = True" unfolding Int.Pls_def lezero_def by auto
28.28 +lemma lezero2: "lezero Int.Min = True" unfolding Int.Min_def lezero_def by auto
28.29 +lemma lezero3: "lezero (Int.Bit0 x) = lezero x" unfolding Int.Bit0_def lezero_def by auto
28.30 +lemma lezero4: "lezero (Int.Bit1 x) = neg x" unfolding Int.Bit1_def lezero_def neg_def by auto
28.31 +lemmas bitlezero = lezero1 lezero2 lezero3 lezero4
28.32 +
28.33 +(* equality for bit strings *)
28.34 +lemmas biteq = eq_bin_simps
28.35 +
28.36 +(* x < y for bit strings *)
28.37 +lemmas bitless = less_bin_simps
28.38 +
28.39 +(* x \<le> y for bit strings *)
28.40 +lemmas bitle = le_bin_simps
28.41 +
28.42 +(* succ for bit strings *)
28.43 +lemmas bitsucc = succ_bin_simps
28.44 +
28.45 +(* pred for bit strings *)
28.46 +lemmas bitpred = pred_bin_simps
28.47 +
28.48 +(* unary minus for bit strings *)
28.49 +lemmas bituminus = minus_bin_simps
28.50 +
28.51 +(* addition for bit strings *)
28.52 +lemmas bitadd = add_bin_simps
28.53 +
28.54 +(* multiplication for bit strings *)
28.55 +lemma mult_Pls_right: "x * Int.Pls = Int.Pls" by (simp add: Pls_def)
28.56 +lemma mult_Min_right: "x * Int.Min = - x" by (subst mult_commute) simp
28.57 +lemma multb0x: "(Int.Bit0 x) * y = Int.Bit0 (x * y)" by (rule mult_Bit0)
28.58 +lemma multxb0: "x * (Int.Bit0 y) = Int.Bit0 (x * y)" unfolding Bit0_def by simp
28.59 +lemma multb1: "(Int.Bit1 x) * (Int.Bit1 y) = Int.Bit1 (Int.Bit0 (x * y) + x + y)"
28.60 + unfolding Bit0_def Bit1_def by (simp add: algebra_simps)
28.61 +lemmas bitmul = mult_Pls mult_Min mult_Pls_right mult_Min_right multb0x multxb0 multb1
28.62 +
28.63 +lemmas bitarith = bitnorm bitiszero bitneg bitlezero biteq bitless bitle bitsucc bitpred bituminus bitadd bitmul
28.64 +
28.65 +definition "nat_norm_number_of (x::nat) = x"
28.66 +
28.67 +lemma nat_norm_number_of: "nat_norm_number_of (number_of w) = (if lezero w then 0 else number_of w)"
28.68 + apply (simp add: nat_norm_number_of_def)
28.69 + unfolding lezero_def iszero_def neg_def
28.70 + apply (simp add: numeral_simps)
28.71 + done
28.72 +
28.73 +(* Normalization of nat literals *)
28.74 +lemma natnorm0: "(0::nat) = number_of (Int.Pls)" by auto
28.75 +lemma natnorm1: "(1 :: nat) = number_of (Int.Bit1 Int.Pls)" by auto
28.76 +lemmas natnorm = natnorm0 natnorm1 nat_norm_number_of
28.77 +
28.78 +(* Suc *)
28.79 +lemma natsuc: "Suc (number_of x) = (if neg x then 1 else number_of (Int.succ x))" by (auto simp add: number_of_is_id)
28.80 +
28.81 +(* Addition for nat *)
28.82 +lemma natadd: "number_of x + ((number_of y)::nat) = (if neg x then (number_of y) else (if neg y then number_of x else (number_of (x + y))))"
28.83 + unfolding nat_number_of_def number_of_is_id neg_def
28.84 + by auto
28.85 +
28.86 +(* Subtraction for nat *)
28.87 +lemma natsub: "(number_of x) - ((number_of y)::nat) =
28.88 + (if neg x then 0 else (if neg y then number_of x else (nat_norm_number_of (number_of (x + (- y))))))"
28.89 + unfolding nat_norm_number_of
28.90 + by (auto simp add: number_of_is_id neg_def lezero_def iszero_def Let_def nat_number_of_def)
28.91 +
28.92 +(* Multiplication for nat *)
28.93 +lemma natmul: "(number_of x) * ((number_of y)::nat) =
28.94 + (if neg x then 0 else (if neg y then 0 else number_of (x * y)))"
28.95 + unfolding nat_number_of_def number_of_is_id neg_def
28.96 + by (simp add: nat_mult_distrib)
28.97 +
28.98 +lemma nateq: "(((number_of x)::nat) = (number_of y)) = ((lezero x \<and> lezero y) \<or> (x = y))"
28.99 + by (auto simp add: iszero_def lezero_def neg_def number_of_is_id)
28.100 +
28.101 +lemma natless: "(((number_of x)::nat) < (number_of y)) = ((x < y) \<and> (\<not> (lezero y)))"
28.102 + by (simp add: lezero_def numeral_simps not_le)
28.103 +
28.104 +lemma natle: "(((number_of x)::nat) \<le> (number_of y)) = (y < x \<longrightarrow> lezero x)"
28.105 + by (auto simp add: number_of_is_id lezero_def nat_number_of_def)
28.106 +
28.107 +fun natfac :: "nat \<Rightarrow> nat"
28.108 + where "natfac n = (if n = 0 then 1 else n * (natfac (n - 1)))"
28.109 +
28.110 +lemmas compute_natarith = bitarith natnorm natsuc natadd natsub natmul nateq natless natle natfac.simps
28.111 +
28.112 +lemma number_eq: "(((number_of x)::'a::{number_ring, linordered_idom}) = (number_of y)) = (x = y)"
28.113 + unfolding number_of_eq
28.114 + apply simp
28.115 + done
28.116 +
28.117 +lemma number_le: "(((number_of x)::'a::{number_ring, linordered_idom}) \<le> (number_of y)) = (x \<le> y)"
28.118 + unfolding number_of_eq
28.119 + apply simp
28.120 + done
28.121 +
28.122 +lemma number_less: "(((number_of x)::'a::{number_ring, linordered_idom}) < (number_of y)) = (x < y)"
28.123 + unfolding number_of_eq
28.124 + apply simp
28.125 + done
28.126 +
28.127 +lemma number_diff: "((number_of x)::'a::{number_ring, linordered_idom}) - number_of y = number_of (x + (- y))"
28.128 + apply (subst diff_number_of_eq)
28.129 + apply simp
28.130 + done
28.131 +
28.132 +lemmas number_norm = number_of_Pls[symmetric] numeral_1_eq_1[symmetric]
28.133 +
28.134 +lemmas compute_numberarith = number_of_minus[symmetric] number_of_add[symmetric] number_diff number_of_mult[symmetric] number_norm number_eq number_le number_less
28.135 +
28.136 +lemma compute_real_of_nat_number_of: "real ((number_of v)::nat) = (if neg v then 0 else number_of v)"
28.137 + by (simp only: real_of_nat_number_of number_of_is_id)
28.138 +
28.139 +lemma compute_nat_of_int_number_of: "nat ((number_of v)::int) = (number_of v)"
28.140 + by simp
28.141 +
28.142 +lemmas compute_num_conversions = compute_real_of_nat_number_of compute_nat_of_int_number_of real_number_of
28.143 +
28.144 +lemmas zpowerarith = zpower_number_of_even
28.145 + zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
28.146 + zpower_Pls zpower_Min
28.147 +
28.148 +(* div, mod *)
28.149 +
28.150 +lemma adjust: "adjust b (q, r) = (if 0 \<le> r - b then (2 * q + 1, r - b) else (2 * q, r))"
28.151 + by (auto simp only: adjust_def)
28.152 +
28.153 +lemma divmod: "divmod_int a b = (if 0\<le>a then
28.154 + if 0\<le>b then posDivAlg a b
28.155 + else if a=0 then (0, 0)
28.156 + else apsnd uminus (negDivAlg (-a) (-b))
28.157 + else
28.158 + if 0<b then negDivAlg a b
28.159 + else apsnd uminus (posDivAlg (-a) (-b)))"
28.160 + by (auto simp only: divmod_int_def)
28.161 +
28.162 +lemmas compute_div_mod = div_int_def mod_int_def divmod adjust apsnd_def map_pair_def posDivAlg.simps negDivAlg.simps
28.163 +
28.164 +
28.165 +
28.166 +(* collecting all the theorems *)
28.167 +
28.168 +lemma even_Pls: "even (Int.Pls) = True"
28.169 + apply (unfold Pls_def even_def)
28.170 + by simp
28.171 +
28.172 +lemma even_Min: "even (Int.Min) = False"
28.173 + apply (unfold Min_def even_def)
28.174 + by simp
28.175 +
28.176 +lemma even_B0: "even (Int.Bit0 x) = True"
28.177 + apply (unfold Bit0_def)
28.178 + by simp
28.179 +
28.180 +lemma even_B1: "even (Int.Bit1 x) = False"
28.181 + apply (unfold Bit1_def)
28.182 + by simp
28.183 +
28.184 +lemma even_number_of: "even ((number_of w)::int) = even w"
28.185 + by (simp only: number_of_is_id)
28.186 +
28.187 +lemmas compute_even = even_Pls even_Min even_B0 even_B1 even_number_of
28.188 +
28.189 +lemmas compute_numeral = compute_if compute_let compute_pair compute_bool
28.190 + compute_natarith compute_numberarith max_def min_def compute_num_conversions zpowerarith compute_div_mod compute_even
28.191 +
28.192 +end
29.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
29.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/Compute_Oracle.thy Sat Mar 17 12:52:40 2012 +0100
29.3 @@ -0,0 +1,11 @@
29.4 +(* Title: HOL/Matrix/Compute_Oracle/Compute_Oracle.thy
29.5 + Author: Steven Obua, TU Munich
29.6 +
29.7 +Steven Obua's evaluator.
29.8 +*)
29.9 +
29.10 +theory Compute_Oracle imports HOL
29.11 +uses "am.ML" "am_compiler.ML" "am_interpreter.ML" "am_ghc.ML" "am_sml.ML" "report.ML" "compute.ML" "linker.ML"
29.12 +begin
29.13 +
29.14 +end
29.15 \ No newline at end of file
30.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
30.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/am.ML Sat Mar 17 12:52:40 2012 +0100
30.3 @@ -0,0 +1,71 @@
30.4 +signature ABSTRACT_MACHINE =
30.5 +sig
30.6 +
30.7 +datatype term = Var of int | Const of int | App of term * term | Abs of term | Computed of term
30.8 +
30.9 +datatype pattern = PVar | PConst of int * (pattern list)
30.10 +
30.11 +datatype guard = Guard of term * term
30.12 +
30.13 +type program
30.14 +
30.15 +exception Compile of string;
30.16 +
30.17 +(* The de-Bruijn index 0 occurring on the right hand side refers to the LAST pattern variable, when traversing the pattern from left to right,
30.18 + 1 to the second last, and so on. *)
30.19 +val compile : (guard list * pattern * term) list -> program
30.20 +
30.21 +exception Run of string;
30.22 +val run : program -> term -> term
30.23 +
30.24 +(* Utilities *)
30.25 +
30.26 +val check_freevars : int -> term -> bool
30.27 +val forall_consts : (int -> bool) -> term -> bool
30.28 +val closed : term -> bool
30.29 +val erase_Computed : term -> term
30.30 +
30.31 +end
30.32 +
30.33 +structure AbstractMachine : ABSTRACT_MACHINE =
30.34 +struct
30.35 +
30.36 +datatype term = Var of int | Const of int | App of term * term | Abs of term | Computed of term
30.37 +
30.38 +datatype pattern = PVar | PConst of int * (pattern list)
30.39 +
30.40 +datatype guard = Guard of term * term
30.41 +
30.42 +type program = unit
30.43 +
30.44 +exception Compile of string;
30.45 +
30.46 +fun erase_Computed (Computed t) = erase_Computed t
30.47 + | erase_Computed (App (t1, t2)) = App (erase_Computed t1, erase_Computed t2)
30.48 + | erase_Computed (Abs t) = Abs (erase_Computed t)
30.49 + | erase_Computed t = t
30.50 +
30.51 +(*Returns true iff at most 0 .. (free-1) occur unbound. therefore
30.52 + check_freevars 0 t iff t is closed*)
30.53 +fun check_freevars free (Var x) = x < free
30.54 + | check_freevars free (Const _) = true
30.55 + | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v
30.56 + | check_freevars free (Abs m) = check_freevars (free+1) m
30.57 + | check_freevars free (Computed t) = check_freevars free t
30.58 +
30.59 +fun forall_consts pred (Const c) = pred c
30.60 + | forall_consts pred (Var _) = true
30.61 + | forall_consts pred (App (u,v)) = forall_consts pred u
30.62 + andalso forall_consts pred v
30.63 + | forall_consts pred (Abs m) = forall_consts pred m
30.64 + | forall_consts pred (Computed t) = forall_consts pred t
30.65 +
30.66 +fun closed t = check_freevars 0 t
30.67 +
30.68 +fun compile _ = raise Compile "abstract machine stub"
30.69 +
30.70 +exception Run of string;
30.71 +
30.72 +fun run _ _ = raise Run "abstract machine stub"
30.73 +
30.74 +end
31.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
31.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/am_compiler.ML Sat Mar 17 12:52:40 2012 +0100
31.3 @@ -0,0 +1,208 @@
31.4 +(* Title: HOL/Matrix/Compute_Oracle/am_compiler.ML
31.5 + Author: Steven Obua
31.6 +*)
31.7 +
31.8 +signature COMPILING_AM =
31.9 +sig
31.10 + include ABSTRACT_MACHINE
31.11 +
31.12 + val set_compiled_rewriter : (term -> term) -> unit
31.13 + val list_nth : 'a list * int -> 'a
31.14 + val list_map : ('a -> 'b) -> 'a list -> 'b list
31.15 +end
31.16 +
31.17 +structure AM_Compiler : COMPILING_AM = struct
31.18 +
31.19 +val list_nth = List.nth;
31.20 +val list_map = map;
31.21 +
31.22 +open AbstractMachine;
31.23 +
31.24 +val compiled_rewriter = Unsynchronized.ref (NONE:(term -> term)Option.option)
31.25 +
31.26 +fun set_compiled_rewriter r = (compiled_rewriter := SOME r)
31.27 +
31.28 +type program = (term -> term)
31.29 +
31.30 +fun count_patternvars PVar = 1
31.31 + | count_patternvars (PConst (_, ps)) =
31.32 + List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
31.33 +
31.34 +fun print_rule (p, t) =
31.35 + let
31.36 + fun str x = string_of_int x
31.37 + fun print_pattern n PVar = (n+1, "x"^(str n))
31.38 + | print_pattern n (PConst (c, [])) = (n, "c"^(str c))
31.39 + | print_pattern n (PConst (c, args)) =
31.40 + let
31.41 + val h = print_pattern n (PConst (c,[]))
31.42 + in
31.43 + print_pattern_list h args
31.44 + end
31.45 + and print_pattern_list r [] = r
31.46 + | print_pattern_list (n, p) (t::ts) =
31.47 + let
31.48 + val (n, t) = print_pattern n t
31.49 + in
31.50 + print_pattern_list (n, "App ("^p^", "^t^")") ts
31.51 + end
31.52 +
31.53 + val (n, pattern) = print_pattern 0 p
31.54 + val pattern =
31.55 + if exists_string Symbol.is_ascii_blank pattern then "(" ^ pattern ^")"
31.56 + else pattern
31.57 +
31.58 + fun print_term d (Var x) = "Var " ^ str x
31.59 + | print_term d (Const c) = "c" ^ str c
31.60 + | print_term d (App (a,b)) = "App (" ^ print_term d a ^ ", " ^ print_term d b ^ ")"
31.61 + | print_term d (Abs c) = "Abs (" ^ print_term (d + 1) c ^ ")"
31.62 + | print_term d (Computed c) = print_term d c
31.63 +
31.64 + fun listvars n = if n = 0 then "x0" else "x"^(str n)^", "^(listvars (n-1))
31.65 +
31.66 + val term = print_term 0 t
31.67 + val term =
31.68 + if n > 0 then "Closure (["^(listvars (n-1))^"], "^term^")"
31.69 + else "Closure ([], "^term^")"
31.70 +
31.71 + in
31.72 + " | weak_reduce (false, stack, "^pattern^") = Continue (false, stack, "^term^")"
31.73 + end
31.74 +
31.75 +fun constants_of PVar = []
31.76 + | constants_of (PConst (c, ps)) = c :: maps constants_of ps
31.77 +
31.78 +fun constants_of_term (Var _) = []
31.79 + | constants_of_term (Abs m) = constants_of_term m
31.80 + | constants_of_term (App (a,b)) = (constants_of_term a)@(constants_of_term b)
31.81 + | constants_of_term (Const c) = [c]
31.82 + | constants_of_term (Computed c) = constants_of_term c
31.83 +
31.84 +fun load_rules sname name prog =
31.85 + let
31.86 + val buffer = Unsynchronized.ref ""
31.87 + fun write s = (buffer := (!buffer)^s)
31.88 + fun writeln s = (write s; write "\n")
31.89 + fun writelist [] = ()
31.90 + | writelist (s::ss) = (writeln s; writelist ss)
31.91 + fun str i = string_of_int i
31.92 + val _ = writelist [
31.93 + "structure "^name^" = struct",
31.94 + "",
31.95 + "datatype term = Dummy | App of term * term | Abs of term | Var of int | Const of int | Closure of term list * term"]
31.96 + val constants = distinct (op =) (maps (fn (p, r) => ((constants_of p)@(constants_of_term r))) prog)
31.97 + val _ = map (fn x => write (" | c"^(str x))) constants
31.98 + val _ = writelist [
31.99 + "",
31.100 + "datatype stack = SEmpty | SAppL of term * stack | SAppR of term * stack | SAbs of stack",
31.101 + "",
31.102 + "type state = bool * stack * term",
31.103 + "",
31.104 + "datatype loopstate = Continue of state | Stop of stack * term",
31.105 + "",
31.106 + "fun proj_C (Continue s) = s",
31.107 + " | proj_C _ = raise Match",
31.108 + "",
31.109 + "fun proj_S (Stop s) = s",
31.110 + " | proj_S _ = raise Match",
31.111 + "",
31.112 + "fun cont (Continue _) = true",
31.113 + " | cont _ = false",
31.114 + "",
31.115 + "fun do_reduction reduce p =",
31.116 + " let",
31.117 + " val s = Unsynchronized.ref (Continue p)",
31.118 + " val _ = while cont (!s) do (s := reduce (proj_C (!s)))",
31.119 + " in",
31.120 + " proj_S (!s)",
31.121 + " end",
31.122 + ""]
31.123 +
31.124 + val _ = writelist [
31.125 + "fun weak_reduce (false, stack, Closure (e, App (a, b))) = Continue (false, SAppL (Closure (e, b), stack), Closure (e, a))",
31.126 + " | weak_reduce (false, SAppL (b, stack), Closure (e, Abs m)) = Continue (false, stack, Closure (b::e, m))",
31.127 + " | weak_reduce (false, stack, c as Closure (e, Abs m)) = Continue (true, stack, c)",
31.128 + " | weak_reduce (false, stack, Closure (e, Var n)) = Continue (false, stack, case "^sname^".list_nth (e, n) of Dummy => Var n | r => r)",
31.129 + " | weak_reduce (false, stack, Closure (e, c)) = Continue (false, stack, c)"]
31.130 + val _ = writelist (map print_rule prog)
31.131 + val _ = writelist [
31.132 + " | weak_reduce (false, stack, clos) = Continue (true, stack, clos)",
31.133 + " | weak_reduce (true, SAppR (a, stack), b) = Continue (false, stack, App (a,b))",
31.134 + " | weak_reduce (true, s as (SAppL (b, stack)), a) = Continue (false, SAppR (a, stack), b)",
31.135 + " | weak_reduce (true, stack, c) = Stop (stack, c)",
31.136 + "",
31.137 + "fun strong_reduce (false, stack, Closure (e, Abs m)) =",
31.138 + " let",
31.139 + " val (stack', wnf) = do_reduction weak_reduce (false, SEmpty, Closure (Dummy::e, m))",
31.140 + " in",
31.141 + " case stack' of",
31.142 + " SEmpty => Continue (false, SAbs stack, wnf)",
31.143 + " | _ => raise ("^sname^".Run \"internal error in strong: weak failed\")",
31.144 + " end",
31.145 + " | strong_reduce (false, stack, clos as (App (u, v))) = Continue (false, SAppL (v, stack), u)",
31.146 + " | strong_reduce (false, stack, clos) = Continue (true, stack, clos)",
31.147 + " | strong_reduce (true, SAbs stack, m) = Continue (false, stack, Abs m)",
31.148 + " | strong_reduce (true, SAppL (b, stack), a) = Continue (false, SAppR (a, stack), b)",
31.149 + " | strong_reduce (true, SAppR (a, stack), b) = Continue (true, stack, App (a, b))",
31.150 + " | strong_reduce (true, stack, clos) = Stop (stack, clos)",
31.151 + ""]
31.152 +
31.153 + val ic = "(case c of "^(implode (map (fn c => (str c)^" => c"^(str c)^" | ") constants))^" _ => Const c)"
31.154 + val _ = writelist [
31.155 + "fun importTerm ("^sname^".Var x) = Var x",
31.156 + " | importTerm ("^sname^".Const c) = "^ic,
31.157 + " | importTerm ("^sname^".App (a, b)) = App (importTerm a, importTerm b)",
31.158 + " | importTerm ("^sname^".Abs m) = Abs (importTerm m)",
31.159 + ""]
31.160 +
31.161 + fun ec c = " | exportTerm c"^(str c)^" = "^sname^".Const "^(str c)
31.162 + val _ = writelist [
31.163 + "fun exportTerm (Var x) = "^sname^".Var x",
31.164 + " | exportTerm (Const c) = "^sname^".Const c",
31.165 + " | exportTerm (App (a,b)) = "^sname^".App (exportTerm a, exportTerm b)",
31.166 + " | exportTerm (Abs m) = "^sname^".Abs (exportTerm m)",
31.167 + " | exportTerm (Closure (closlist, clos)) = raise ("^sname^".Run \"internal error, cannot export Closure\")",
31.168 + " | exportTerm Dummy = raise ("^sname^".Run \"internal error, cannot export Dummy\")"]
31.169 + val _ = writelist (map ec constants)
31.170 +
31.171 + val _ = writelist [
31.172 + "",
31.173 + "fun rewrite t = ",
31.174 + " let",
31.175 + " val (stack, wnf) = do_reduction weak_reduce (false, SEmpty, Closure ([], importTerm t))",
31.176 + " in",
31.177 + " case stack of ",
31.178 + " SEmpty => (case do_reduction strong_reduce (false, SEmpty, wnf) of",
31.179 + " (SEmpty, snf) => exportTerm snf",
31.180 + " | _ => raise ("^sname^".Run \"internal error in rewrite: strong failed\"))",
31.181 + " | _ => (raise ("^sname^".Run \"internal error in rewrite: weak failed\"))",
31.182 + " end",
31.183 + "",
31.184 + "val _ = "^sname^".set_compiled_rewriter rewrite",
31.185 + "",
31.186 + "end;"]
31.187 +
31.188 + in
31.189 + compiled_rewriter := NONE;
31.190 + use_text ML_Env.local_context (1, "") false (!buffer);
31.191 + case !compiled_rewriter of
31.192 + NONE => raise (Compile "cannot communicate with compiled function")
31.193 + | SOME r => (compiled_rewriter := NONE; r)
31.194 + end
31.195 +
31.196 +fun compile eqs =
31.197 + let
31.198 + val _ = if exists (fn (a,_,_) => not (null a)) eqs then raise Compile ("cannot deal with guards") else ()
31.199 + val eqs = map (fn (_,b,c) => (b,c)) eqs
31.200 + fun check (p, r) = if check_freevars (count_patternvars p) r then () else raise Compile ("unbound variables in rule")
31.201 + val _ = map (fn (p, r) =>
31.202 + (check (p, r);
31.203 + case p of PVar => raise (Compile "pattern is just a variable") | _ => ())) eqs
31.204 + in
31.205 + load_rules "AM_Compiler" "AM_compiled_code" eqs
31.206 + end
31.207 +
31.208 +fun run prog t = prog t
31.209 +
31.210 +end
31.211 +
32.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
32.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/am_ghc.ML Sat Mar 17 12:52:40 2012 +0100
32.3 @@ -0,0 +1,324 @@
32.4 +(* Title: HOL/Matrix/Compute_Oracle/am_ghc.ML
32.5 + Author: Steven Obua
32.6 +*)
32.7 +
32.8 +structure AM_GHC : ABSTRACT_MACHINE =
32.9 +struct
32.10 +
32.11 +open AbstractMachine;
32.12 +
32.13 +type program = string * string * (int Inttab.table)
32.14 +
32.15 +fun count_patternvars PVar = 1
32.16 + | count_patternvars (PConst (_, ps)) =
32.17 + List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
32.18 +
32.19 +fun update_arity arity code a =
32.20 + (case Inttab.lookup arity code of
32.21 + NONE => Inttab.update_new (code, a) arity
32.22 + | SOME (a': int) => if a > a' then Inttab.update (code, a) arity else arity)
32.23 +
32.24 +(* We have to find out the maximal arity of each constant *)
32.25 +fun collect_pattern_arity PVar arity = arity
32.26 + | collect_pattern_arity (PConst (c, args)) arity = fold collect_pattern_arity args (update_arity arity c (length args))
32.27 +
32.28 +local
32.29 +fun collect applevel (Var _) arity = arity
32.30 + | collect applevel (Const c) arity = update_arity arity c applevel
32.31 + | collect applevel (Abs m) arity = collect 0 m arity
32.32 + | collect applevel (App (a,b)) arity = collect 0 b (collect (applevel + 1) a arity)
32.33 +in
32.34 +fun collect_term_arity t arity = collect 0 t arity
32.35 +end
32.36 +
32.37 +fun nlift level n (Var m) = if m < level then Var m else Var (m+n)
32.38 + | nlift level n (Const c) = Const c
32.39 + | nlift level n (App (a,b)) = App (nlift level n a, nlift level n b)
32.40 + | nlift level n (Abs b) = Abs (nlift (level+1) n b)
32.41 +
32.42 +fun rep n x = if n = 0 then [] else x::(rep (n-1) x)
32.43 +
32.44 +fun adjust_rules rules =
32.45 + let
32.46 + val arity = fold (fn (p, t) => fn arity => collect_term_arity t (collect_pattern_arity p arity)) rules Inttab.empty
32.47 + fun arity_of c = the (Inttab.lookup arity c)
32.48 + fun adjust_pattern PVar = PVar
32.49 + | adjust_pattern (C as PConst (c, args)) = if (length args <> arity_of c) then raise Compile ("Constant inside pattern must have maximal arity") else C
32.50 + fun adjust_rule (PVar, _) = raise Compile ("pattern may not be a variable")
32.51 + | adjust_rule (rule as (p as PConst (c, args),t)) =
32.52 + let
32.53 + val _ = if not (check_freevars (count_patternvars p) t) then raise Compile ("unbound variables on right hand side") else ()
32.54 + val args = map adjust_pattern args
32.55 + val len = length args
32.56 + val arity = arity_of c
32.57 + fun lift level n (Var m) = if m < level then Var m else Var (m+n)
32.58 + | lift level n (Const c) = Const c
32.59 + | lift level n (App (a,b)) = App (lift level n a, lift level n b)
32.60 + | lift level n (Abs b) = Abs (lift (level+1) n b)
32.61 + val lift = lift 0
32.62 + fun adjust_term n t = if n=0 then t else adjust_term (n-1) (App (t, Var (n-1)))
32.63 + in
32.64 + if len = arity then
32.65 + rule
32.66 + else if arity >= len then
32.67 + (PConst (c, args @ (rep (arity-len) PVar)), adjust_term (arity-len) (lift (arity-len) t))
32.68 + else (raise Compile "internal error in adjust_rule")
32.69 + end
32.70 + in
32.71 + (arity, map adjust_rule rules)
32.72 + end
32.73 +
32.74 +fun print_term arity_of n =
32.75 +let
32.76 + fun str x = string_of_int x
32.77 + fun protect_blank s = if exists_string Symbol.is_ascii_blank s then "(" ^ s ^")" else s
32.78 +
32.79 + fun print_apps d f [] = f
32.80 + | print_apps d f (a::args) = print_apps d ("app "^(protect_blank f)^" "^(protect_blank (print_term d a))) args
32.81 + and print_call d (App (a, b)) args = print_call d a (b::args)
32.82 + | print_call d (Const c) args =
32.83 + (case arity_of c of
32.84 + NONE => print_apps d ("Const "^(str c)) args
32.85 + | SOME a =>
32.86 + let
32.87 + val len = length args
32.88 + in
32.89 + if a <= len then
32.90 + let
32.91 + val s = "c"^(str c)^(implode (map (fn t => " "^(protect_blank (print_term d t))) (List.take (args, a))))
32.92 + in
32.93 + print_apps d s (List.drop (args, a))
32.94 + end
32.95 + else
32.96 + let
32.97 + fun mk_apps n t = if n = 0 then t else mk_apps (n-1) (App (t, Var (n-1)))
32.98 + fun mk_lambdas n t = if n = 0 then t else mk_lambdas (n-1) (Abs t)
32.99 + fun append_args [] t = t
32.100 + | append_args (c::cs) t = append_args cs (App (t, c))
32.101 + in
32.102 + print_term d (mk_lambdas (a-len) (mk_apps (a-len) (nlift 0 (a-len) (append_args args (Const c)))))
32.103 + end
32.104 + end)
32.105 + | print_call d t args = print_apps d (print_term d t) args
32.106 + and print_term d (Var x) = if x < d then "b"^(str (d-x-1)) else "x"^(str (n-(x-d)-1))
32.107 + | print_term d (Abs c) = "Abs (\\b"^(str d)^" -> "^(print_term (d + 1) c)^")"
32.108 + | print_term d t = print_call d t []
32.109 +in
32.110 + print_term 0
32.111 +end
32.112 +
32.113 +fun print_rule arity_of (p, t) =
32.114 + let
32.115 + fun str x = string_of_int x
32.116 + fun print_pattern top n PVar = (n+1, "x"^(str n))
32.117 + | print_pattern top n (PConst (c, [])) = (n, (if top then "c" else "C")^(str c))
32.118 + | print_pattern top n (PConst (c, args)) =
32.119 + let
32.120 + val (n,s) = print_pattern_list (n, (if top then "c" else "C")^(str c)) args
32.121 + in
32.122 + (n, if top then s else "("^s^")")
32.123 + end
32.124 + and print_pattern_list r [] = r
32.125 + | print_pattern_list (n, p) (t::ts) =
32.126 + let
32.127 + val (n, t) = print_pattern false n t
32.128 + in
32.129 + print_pattern_list (n, p^" "^t) ts
32.130 + end
32.131 + val (n, pattern) = print_pattern true 0 p
32.132 + in
32.133 + pattern^" = "^(print_term arity_of n t)
32.134 + end
32.135 +
32.136 +fun group_rules rules =
32.137 + let
32.138 + fun add_rule (r as (PConst (c,_), _)) groups =
32.139 + let
32.140 + val rs = (case Inttab.lookup groups c of NONE => [] | SOME rs => rs)
32.141 + in
32.142 + Inttab.update (c, r::rs) groups
32.143 + end
32.144 + | add_rule _ _ = raise Compile "internal error group_rules"
32.145 + in
32.146 + fold_rev add_rule rules Inttab.empty
32.147 + end
32.148 +
32.149 +fun haskell_prog name rules =
32.150 + let
32.151 + val buffer = Unsynchronized.ref ""
32.152 + fun write s = (buffer := (!buffer)^s)
32.153 + fun writeln s = (write s; write "\n")
32.154 + fun writelist [] = ()
32.155 + | writelist (s::ss) = (writeln s; writelist ss)
32.156 + fun str i = string_of_int i
32.157 + val (arity, rules) = adjust_rules rules
32.158 + val rules = group_rules rules
32.159 + val constants = Inttab.keys arity
32.160 + fun arity_of c = Inttab.lookup arity c
32.161 + fun rep_str s n = implode (rep n s)
32.162 + fun indexed s n = s^(str n)
32.163 + fun section n = if n = 0 then [] else (section (n-1))@[n-1]
32.164 + fun make_show c =
32.165 + let
32.166 + val args = section (the (arity_of c))
32.167 + in
32.168 + " show ("^(indexed "C" c)^(implode (map (indexed " a") args))^") = "
32.169 + ^"\""^(indexed "C" c)^"\""^(implode (map (fn a => "++(show "^(indexed "a" a)^")") args))
32.170 + end
32.171 + fun default_case c =
32.172 + let
32.173 + val args = implode (map (indexed " x") (section (the (arity_of c))))
32.174 + in
32.175 + (indexed "c" c)^args^" = "^(indexed "C" c)^args
32.176 + end
32.177 + val _ = writelist [
32.178 + "module "^name^" where",
32.179 + "",
32.180 + "data Term = Const Integer | App Term Term | Abs (Term -> Term)",
32.181 + " "^(implode (map (fn c => " | C"^(str c)^(rep_str " Term" (the (arity_of c)))) constants)),
32.182 + "",
32.183 + "instance Show Term where"]
32.184 + val _ = writelist (map make_show constants)
32.185 + val _ = writelist [
32.186 + " show (Const c) = \"c\"++(show c)",
32.187 + " show (App a b) = \"A\"++(show a)++(show b)",
32.188 + " show (Abs _) = \"L\"",
32.189 + ""]
32.190 + val _ = writelist [
32.191 + "app (Abs a) b = a b",
32.192 + "app a b = App a b",
32.193 + "",
32.194 + "calc s c = writeFile s (show c)",
32.195 + ""]
32.196 + fun list_group c = (writelist (case Inttab.lookup rules c of
32.197 + NONE => [default_case c, ""]
32.198 + | SOME (rs as ((PConst (_, []), _)::rs')) =>
32.199 + if not (null rs') then raise Compile "multiple declaration of constant"
32.200 + else (map (print_rule arity_of) rs) @ [""]
32.201 + | SOME rs => (map (print_rule arity_of) rs) @ [default_case c, ""]))
32.202 + val _ = map list_group constants
32.203 + in
32.204 + (arity, !buffer)
32.205 + end
32.206 +
32.207 +val guid_counter = Unsynchronized.ref 0
32.208 +fun get_guid () =
32.209 + let
32.210 + val c = !guid_counter
32.211 + val _ = guid_counter := !guid_counter + 1
32.212 + in
32.213 + string_of_int (Time.toMicroseconds (Time.now ())) ^ string_of_int c
32.214 + end
32.215 +
32.216 +fun tmp_file s = Path.implode (Path.expand (File.tmp_path (Path.basic s)));
32.217 +
32.218 +fun writeTextFile name s = File.write (Path.explode name) s
32.219 +
32.220 +fun fileExists name = ((OS.FileSys.fileSize name; true) handle OS.SysErr _ => false)
32.221 +
32.222 +fun compile eqs =
32.223 + let
32.224 + val _ = if exists (fn (a,_,_) => not (null a)) eqs then raise Compile ("cannot deal with guards") else ()
32.225 + val eqs = map (fn (_,b,c) => (b,c)) eqs
32.226 + val guid = get_guid ()
32.227 + val module = "AMGHC_Prog_"^guid
32.228 + val (arity, source) = haskell_prog module eqs
32.229 + val module_file = tmp_file (module^".hs")
32.230 + val object_file = tmp_file (module^".o")
32.231 + val _ = writeTextFile module_file source
32.232 + val _ = Isabelle_System.bash ("exec \"$ISABELLE_GHC\" -c " ^ module_file)
32.233 + val _ =
32.234 + if not (fileExists object_file) then
32.235 + raise Compile ("Failure compiling haskell code (ISABELLE_GHC='" ^ getenv "ISABELLE_GHC" ^ "')")
32.236 + else ()
32.237 + in
32.238 + (guid, module_file, arity)
32.239 + end
32.240 +
32.241 +fun readResultFile name = File.read (Path.explode name)
32.242 +
32.243 +fun parse_result arity_of result =
32.244 + let
32.245 + val result = String.explode result
32.246 + fun shift NONE x = SOME x
32.247 + | shift (SOME y) x = SOME (y*10 + x)
32.248 + fun parse_int' x (#"0"::rest) = parse_int' (shift x 0) rest
32.249 + | parse_int' x (#"1"::rest) = parse_int' (shift x 1) rest
32.250 + | parse_int' x (#"2"::rest) = parse_int' (shift x 2) rest
32.251 + | parse_int' x (#"3"::rest) = parse_int' (shift x 3) rest
32.252 + | parse_int' x (#"4"::rest) = parse_int' (shift x 4) rest
32.253 + | parse_int' x (#"5"::rest) = parse_int' (shift x 5) rest
32.254 + | parse_int' x (#"6"::rest) = parse_int' (shift x 6) rest
32.255 + | parse_int' x (#"7"::rest) = parse_int' (shift x 7) rest
32.256 + | parse_int' x (#"8"::rest) = parse_int' (shift x 8) rest
32.257 + | parse_int' x (#"9"::rest) = parse_int' (shift x 9) rest
32.258 + | parse_int' x rest = (x, rest)
32.259 + fun parse_int rest = parse_int' NONE rest
32.260 +
32.261 + fun parse (#"C"::rest) =
32.262 + (case parse_int rest of
32.263 + (SOME c, rest) =>
32.264 + let
32.265 + val (args, rest) = parse_list (the (arity_of c)) rest
32.266 + fun app_args [] t = t
32.267 + | app_args (x::xs) t = app_args xs (App (t, x))
32.268 + in
32.269 + (app_args args (Const c), rest)
32.270 + end
32.271 + | (NONE, _) => raise Run "parse C")
32.272 + | parse (#"c"::rest) =
32.273 + (case parse_int rest of
32.274 + (SOME c, rest) => (Const c, rest)
32.275 + | _ => raise Run "parse c")
32.276 + | parse (#"A"::rest) =
32.277 + let
32.278 + val (a, rest) = parse rest
32.279 + val (b, rest) = parse rest
32.280 + in
32.281 + (App (a,b), rest)
32.282 + end
32.283 + | parse (#"L"::_) = raise Run "there may be no abstraction in the result"
32.284 + | parse _ = raise Run "invalid result"
32.285 + and parse_list n rest =
32.286 + if n = 0 then
32.287 + ([], rest)
32.288 + else
32.289 + let
32.290 + val (x, rest) = parse rest
32.291 + val (xs, rest) = parse_list (n-1) rest
32.292 + in
32.293 + (x::xs, rest)
32.294 + end
32.295 + val (parsed, rest) = parse result
32.296 + fun is_blank (#" "::rest) = is_blank rest
32.297 + | is_blank (#"\n"::rest) = is_blank rest
32.298 + | is_blank [] = true
32.299 + | is_blank _ = false
32.300 + in
32.301 + if is_blank rest then parsed else raise Run "non-blank suffix in result file"
32.302 + end
32.303 +
32.304 +fun run (guid, module_file, arity) t =
32.305 + let
32.306 + val _ = if check_freevars 0 t then () else raise Run ("can only compute closed terms")
32.307 + fun arity_of c = Inttab.lookup arity c
32.308 + val callguid = get_guid()
32.309 + val module = "AMGHC_Prog_"^guid
32.310 + val call = module^"_Call_"^callguid
32.311 + val result_file = tmp_file (module^"_Result_"^callguid^".txt")
32.312 + val call_file = tmp_file (call^".hs")
32.313 + val term = print_term arity_of 0 t
32.314 + val call_source = "module "^call^" where\n\nimport "^module^"\n\ncall = "^module^".calc \""^result_file^"\" ("^term^")"
32.315 + val _ = writeTextFile call_file call_source
32.316 + val _ = Isabelle_System.bash ("exec \"$ISABELLE_GHC\" -e \""^call^".call\" "^module_file^" "^call_file)
32.317 + val result = readResultFile result_file handle IO.Io _ =>
32.318 + raise Run ("Failure running haskell compiler (ISABELLE_GHC='" ^ getenv "ISABELLE_GHC" ^ "')")
32.319 + val t' = parse_result arity_of result
32.320 + val _ = OS.FileSys.remove call_file
32.321 + val _ = OS.FileSys.remove result_file
32.322 + in
32.323 + t'
32.324 + end
32.325 +
32.326 +end
32.327 +
33.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
33.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/am_interpreter.ML Sat Mar 17 12:52:40 2012 +0100
33.3 @@ -0,0 +1,211 @@
33.4 +(* Title: HOL/Matrix/Compute_Oracle/am_interpreter.ML
33.5 + Author: Steven Obua
33.6 +*)
33.7 +
33.8 +signature AM_BARRAS =
33.9 +sig
33.10 + include ABSTRACT_MACHINE
33.11 + val max_reductions : int option Unsynchronized.ref
33.12 +end
33.13 +
33.14 +structure AM_Interpreter : AM_BARRAS = struct
33.15 +
33.16 +open AbstractMachine;
33.17 +
33.18 +datatype closure = CDummy | CVar of int | CConst of int
33.19 + | CApp of closure * closure | CAbs of closure
33.20 + | Closure of (closure list) * closure
33.21 +
33.22 +structure prog_struct = Table(type key = int*int val ord = prod_ord int_ord int_ord);
33.23 +
33.24 +datatype program = Program of ((pattern * closure * (closure*closure) list) list) prog_struct.table
33.25 +
33.26 +datatype stack = SEmpty | SAppL of closure * stack | SAppR of closure * stack | SAbs of stack
33.27 +
33.28 +fun clos_of_term (Var x) = CVar x
33.29 + | clos_of_term (Const c) = CConst c
33.30 + | clos_of_term (App (u, v)) = CApp (clos_of_term u, clos_of_term v)
33.31 + | clos_of_term (Abs u) = CAbs (clos_of_term u)
33.32 + | clos_of_term (Computed t) = clos_of_term t
33.33 +
33.34 +fun term_of_clos (CVar x) = Var x
33.35 + | term_of_clos (CConst c) = Const c
33.36 + | term_of_clos (CApp (u, v)) = App (term_of_clos u, term_of_clos v)
33.37 + | term_of_clos (CAbs u) = Abs (term_of_clos u)
33.38 + | term_of_clos (Closure _) = raise (Run "internal error: closure in normalized term found")
33.39 + | term_of_clos CDummy = raise (Run "internal error: dummy in normalized term found")
33.40 +
33.41 +fun resolve_closure closures (CVar x) = (case nth closures x of CDummy => CVar x | r => r)
33.42 + | resolve_closure closures (CConst c) = CConst c
33.43 + | resolve_closure closures (CApp (u, v)) = CApp (resolve_closure closures u, resolve_closure closures v)
33.44 + | resolve_closure closures (CAbs u) = CAbs (resolve_closure (CDummy::closures) u)
33.45 + | resolve_closure closures (CDummy) = raise (Run "internal error: resolve_closure applied to CDummy")
33.46 + | resolve_closure closures (Closure (e, u)) = resolve_closure e u
33.47 +
33.48 +fun resolve_closure' c = resolve_closure [] c
33.49 +
33.50 +fun resolve_stack tm SEmpty = tm
33.51 + | resolve_stack tm (SAppL (c, s)) = resolve_stack (CApp (tm, resolve_closure' c)) s
33.52 + | resolve_stack tm (SAppR (c, s)) = resolve_stack (CApp (resolve_closure' c, tm)) s
33.53 + | resolve_stack tm (SAbs s) = resolve_stack (CAbs tm) s
33.54 +
33.55 +fun resolve (stack, closure) =
33.56 + let
33.57 + val _ = writeln "start resolving"
33.58 + val t = resolve_stack (resolve_closure' closure) stack
33.59 + val _ = writeln "finished resolving"
33.60 + in
33.61 + t
33.62 + end
33.63 +
33.64 +fun strip_closure args (CApp (a,b)) = strip_closure (b::args) a
33.65 + | strip_closure args x = (x, args)
33.66 +
33.67 +fun len_head_of_closure n (CApp (a, _)) = len_head_of_closure (n+1) a
33.68 + | len_head_of_closure n x = (n, x)
33.69 +
33.70 +
33.71 +(* earlier occurrence of PVar corresponds to higher de Bruijn index *)
33.72 +fun pattern_match args PVar clos = SOME (clos::args)
33.73 + | pattern_match args (PConst (c, patterns)) clos =
33.74 + let
33.75 + val (f, closargs) = strip_closure [] clos
33.76 + in
33.77 + case f of
33.78 + CConst d =>
33.79 + if c = d then
33.80 + pattern_match_list args patterns closargs
33.81 + else
33.82 + NONE
33.83 + | _ => NONE
33.84 + end
33.85 +and pattern_match_list args [] [] = SOME args
33.86 + | pattern_match_list args (p::ps) (c::cs) =
33.87 + (case pattern_match args p c of
33.88 + NONE => NONE
33.89 + | SOME args => pattern_match_list args ps cs)
33.90 + | pattern_match_list _ _ _ = NONE
33.91 +
33.92 +fun count_patternvars PVar = 1
33.93 + | count_patternvars (PConst (_, ps)) = List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
33.94 +
33.95 +fun pattern_key (PConst (c, ps)) = (c, length ps)
33.96 + | pattern_key _ = raise (Compile "pattern reduces to variable")
33.97 +
33.98 +(*Returns true iff at most 0 .. (free-1) occur unbound. therefore
33.99 + check_freevars 0 t iff t is closed*)
33.100 +fun check_freevars free (Var x) = x < free
33.101 + | check_freevars free (Const _) = true
33.102 + | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v
33.103 + | check_freevars free (Abs m) = check_freevars (free+1) m
33.104 + | check_freevars free (Computed t) = check_freevars free t
33.105 +
33.106 +fun compile eqs =
33.107 + let
33.108 + fun check p r = if check_freevars p r then () else raise Compile ("unbound variables in rule")
33.109 + fun check_guard p (Guard (a,b)) = (check p a; check p b)
33.110 + fun clos_of_guard (Guard (a,b)) = (clos_of_term a, clos_of_term b)
33.111 + val eqs = map (fn (guards, p, r) => let val pcount = count_patternvars p val _ = map (check_guard pcount) (guards) val _ = check pcount r in
33.112 + (pattern_key p, (p, clos_of_term r, map clos_of_guard guards)) end) eqs
33.113 + fun merge (k, a) table = prog_struct.update (k, case prog_struct.lookup table k of NONE => [a] | SOME l => a::l) table
33.114 + val p = fold merge eqs prog_struct.empty
33.115 + in
33.116 + Program p
33.117 + end
33.118 +
33.119 +
33.120 +type state = bool * program * stack * closure
33.121 +
33.122 +datatype loopstate = Continue of state | Stop of stack * closure
33.123 +
33.124 +fun proj_C (Continue s) = s
33.125 + | proj_C _ = raise Match
33.126 +
33.127 +exception InterruptedExecution of stack * closure
33.128 +
33.129 +fun proj_S (Stop s) = s
33.130 + | proj_S (Continue (_,_,s,c)) = (s,c)
33.131 +
33.132 +fun cont (Continue _) = true
33.133 + | cont _ = false
33.134 +
33.135 +val max_reductions = Unsynchronized.ref (NONE : int option)
33.136 +
33.137 +fun do_reduction reduce p =
33.138 + let
33.139 + val s = Unsynchronized.ref (Continue p)
33.140 + val counter = Unsynchronized.ref 0
33.141 + val _ = case !max_reductions of
33.142 + NONE => while cont (!s) do (s := reduce (proj_C (!s)))
33.143 + | SOME m => while cont (!s) andalso (!counter < m) do (s := reduce (proj_C (!s)); counter := (!counter) + 1)
33.144 + in
33.145 + case !max_reductions of
33.146 + SOME m => if !counter >= m then raise InterruptedExecution (proj_S (!s)) else proj_S (!s)
33.147 + | NONE => proj_S (!s)
33.148 + end
33.149 +
33.150 +fun match_rules prog n [] clos = NONE
33.151 + | match_rules prog n ((p,eq,guards)::rs) clos =
33.152 + case pattern_match [] p clos of
33.153 + NONE => match_rules prog (n+1) rs clos
33.154 + | SOME args => if forall (guard_checks prog args) guards then SOME (Closure (args, eq)) else match_rules prog (n+1) rs clos
33.155 +and guard_checks prog args (a,b) = (simp prog (Closure (args, a)) = simp prog (Closure (args, b)))
33.156 +and match_closure (p as (Program prog)) clos =
33.157 + case len_head_of_closure 0 clos of
33.158 + (len, CConst c) =>
33.159 + (case prog_struct.lookup prog (c, len) of
33.160 + NONE => NONE
33.161 + | SOME rules => match_rules p 0 rules clos)
33.162 + | _ => NONE
33.163 +
33.164 +and weak_reduce (false, prog, stack, Closure (e, CApp (a, b))) = Continue (false, prog, SAppL (Closure (e, b), stack), Closure (e, a))
33.165 + | weak_reduce (false, prog, SAppL (b, stack), Closure (e, CAbs m)) = Continue (false, prog, stack, Closure (b::e, m))
33.166 + | weak_reduce (false, prog, stack, Closure (e, CVar n)) = Continue (false, prog, stack, case nth e n of CDummy => CVar n | r => r)
33.167 + | weak_reduce (false, prog, stack, Closure (_, c as CConst _)) = Continue (false, prog, stack, c)
33.168 + | weak_reduce (false, prog, stack, clos) =
33.169 + (case match_closure prog clos of
33.170 + NONE => Continue (true, prog, stack, clos)
33.171 + | SOME r => Continue (false, prog, stack, r))
33.172 + | weak_reduce (true, prog, SAppR (a, stack), b) = Continue (false, prog, stack, CApp (a,b))
33.173 + | weak_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
33.174 + | weak_reduce (true, prog, stack, c) = Stop (stack, c)
33.175 +
33.176 +and strong_reduce (false, prog, stack, Closure (e, CAbs m)) =
33.177 + (let
33.178 + val (stack', wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure (CDummy::e, m))
33.179 + in
33.180 + case stack' of
33.181 + SEmpty => Continue (false, prog, SAbs stack, wnf)
33.182 + | _ => raise (Run "internal error in strong: weak failed")
33.183 + end handle InterruptedExecution state => raise InterruptedExecution (stack, resolve state))
33.184 + | strong_reduce (false, prog, stack, CApp (u, v)) = Continue (false, prog, SAppL (v, stack), u)
33.185 + | strong_reduce (false, prog, stack, clos) = Continue (true, prog, stack, clos)
33.186 + | strong_reduce (true, prog, SAbs stack, m) = Continue (false, prog, stack, CAbs m)
33.187 + | strong_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b)
33.188 + | strong_reduce (true, prog, SAppR (a, stack), b) = Continue (true, prog, stack, CApp (a, b))
33.189 + | strong_reduce (true, prog, stack, clos) = Stop (stack, clos)
33.190 +
33.191 +and simp prog t =
33.192 + (let
33.193 + val (stack, wnf) = do_reduction weak_reduce (false, prog, SEmpty, t)
33.194 + in
33.195 + case stack of
33.196 + SEmpty => (case do_reduction strong_reduce (false, prog, SEmpty, wnf) of
33.197 + (SEmpty, snf) => snf
33.198 + | _ => raise (Run "internal error in run: strong failed"))
33.199 + | _ => raise (Run "internal error in run: weak failed")
33.200 + end handle InterruptedExecution state => resolve state)
33.201 +
33.202 +
33.203 +fun run prog t =
33.204 + (let
33.205 + val (stack, wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure ([], clos_of_term t))
33.206 + in
33.207 + case stack of
33.208 + SEmpty => (case do_reduction strong_reduce (false, prog, SEmpty, wnf) of
33.209 + (SEmpty, snf) => term_of_clos snf
33.210 + | _ => raise (Run "internal error in run: strong failed"))
33.211 + | _ => raise (Run "internal error in run: weak failed")
33.212 + end handle InterruptedExecution state => term_of_clos (resolve state))
33.213 +
33.214 +end
34.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
34.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/am_sml.ML Sat Mar 17 12:52:40 2012 +0100
34.3 @@ -0,0 +1,517 @@
34.4 +(* Title: HOL/Matrix/Compute_Oracle/am_sml.ML
34.5 + Author: Steven Obua
34.6 +
34.7 +TODO: "parameterless rewrite cannot be used in pattern": In a lot of
34.8 +cases it CAN be used, and these cases should be handled
34.9 +properly; right now, all cases raise an exception.
34.10 +*)
34.11 +
34.12 +signature AM_SML =
34.13 +sig
34.14 + include ABSTRACT_MACHINE
34.15 + val save_result : (string * term) -> unit
34.16 + val set_compiled_rewriter : (term -> term) -> unit
34.17 + val list_nth : 'a list * int -> 'a
34.18 + val dump_output : (string option) Unsynchronized.ref
34.19 +end
34.20 +
34.21 +structure AM_SML : AM_SML = struct
34.22 +
34.23 +open AbstractMachine;
34.24 +
34.25 +val dump_output = Unsynchronized.ref (NONE: string option)
34.26 +
34.27 +type program = term Inttab.table * (term -> term)
34.28 +
34.29 +val saved_result = Unsynchronized.ref (NONE:(string*term)option)
34.30 +
34.31 +fun save_result r = (saved_result := SOME r)
34.32 +
34.33 +val list_nth = List.nth
34.34 +
34.35 +val compiled_rewriter = Unsynchronized.ref (NONE:(term -> term)Option.option)
34.36 +
34.37 +fun set_compiled_rewriter r = (compiled_rewriter := SOME r)
34.38 +
34.39 +fun count_patternvars PVar = 1
34.40 + | count_patternvars (PConst (_, ps)) =
34.41 + List.foldl (fn (p, count) => (count_patternvars p)+count) 0 ps
34.42 +
34.43 +fun update_arity arity code a =
34.44 + (case Inttab.lookup arity code of
34.45 + NONE => Inttab.update_new (code, a) arity
34.46 + | SOME (a': int) => if a > a' then Inttab.update (code, a) arity else arity)
34.47 +
34.48 +(* We have to find out the maximal arity of each constant *)
34.49 +fun collect_pattern_arity PVar arity = arity
34.50 + | collect_pattern_arity (PConst (c, args)) arity = fold collect_pattern_arity args (update_arity arity c (length args))
34.51 +
34.52 +(* We also need to find out the maximal toplevel arity of each function constant *)
34.53 +fun collect_pattern_toplevel_arity PVar arity = raise Compile "internal error: collect_pattern_toplevel_arity"
34.54 + | collect_pattern_toplevel_arity (PConst (c, args)) arity = update_arity arity c (length args)
34.55 +
34.56 +local
34.57 +fun collect applevel (Var _) arity = arity
34.58 + | collect applevel (Const c) arity = update_arity arity c applevel
34.59 + | collect applevel (Abs m) arity = collect 0 m arity
34.60 + | collect applevel (App (a,b)) arity = collect 0 b (collect (applevel + 1) a arity)
34.61 +in
34.62 +fun collect_term_arity t arity = collect 0 t arity
34.63 +end
34.64 +
34.65 +fun collect_guard_arity (Guard (a,b)) arity = collect_term_arity b (collect_term_arity a arity)
34.66 +
34.67 +
34.68 +fun rep n x = if n < 0 then raise Compile "internal error: rep" else if n = 0 then [] else x::(rep (n-1) x)
34.69 +
34.70 +fun beta (Const c) = Const c
34.71 + | beta (Var i) = Var i
34.72 + | beta (App (Abs m, b)) = beta (unlift 0 (subst 0 m (lift 0 b)))
34.73 + | beta (App (a, b)) =
34.74 + (case beta a of
34.75 + Abs m => beta (App (Abs m, b))
34.76 + | a => App (a, beta b))
34.77 + | beta (Abs m) = Abs (beta m)
34.78 + | beta (Computed t) = Computed t
34.79 +and subst x (Const c) t = Const c
34.80 + | subst x (Var i) t = if i = x then t else Var i
34.81 + | subst x (App (a,b)) t = App (subst x a t, subst x b t)
34.82 + | subst x (Abs m) t = Abs (subst (x+1) m (lift 0 t))
34.83 +and lift level (Const c) = Const c
34.84 + | lift level (App (a,b)) = App (lift level a, lift level b)
34.85 + | lift level (Var i) = if i < level then Var i else Var (i+1)
34.86 + | lift level (Abs m) = Abs (lift (level + 1) m)
34.87 +and unlift level (Const c) = Const c
34.88 + | unlift level (App (a, b)) = App (unlift level a, unlift level b)
34.89 + | unlift level (Abs m) = Abs (unlift (level+1) m)
34.90 + | unlift level (Var i) = if i < level then Var i else Var (i-1)
34.91 +
34.92 +fun nlift level n (Var m) = if m < level then Var m else Var (m+n)
34.93 + | nlift level n (Const c) = Const c
34.94 + | nlift level n (App (a,b)) = App (nlift level n a, nlift level n b)
34.95 + | nlift level n (Abs b) = Abs (nlift (level+1) n b)
34.96 +
34.97 +fun subst_const (c, t) (Const c') = if c = c' then t else Const c'
34.98 + | subst_const _ (Var i) = Var i
34.99 + | subst_const ct (App (a, b)) = App (subst_const ct a, subst_const ct b)
34.100 + | subst_const ct (Abs m) = Abs (subst_const ct m)
34.101 +
34.102 +(* Remove all rules that are just parameterless rewrites. This is necessary because SML does not allow functions with no parameters. *)
34.103 +fun inline_rules rules =
34.104 + let
34.105 + fun term_contains_const c (App (a, b)) = term_contains_const c a orelse term_contains_const c b
34.106 + | term_contains_const c (Abs m) = term_contains_const c m
34.107 + | term_contains_const c (Var _) = false
34.108 + | term_contains_const c (Const c') = (c = c')
34.109 + fun find_rewrite [] = NONE
34.110 + | find_rewrite ((prems, PConst (c, []), r) :: _) =
34.111 + if check_freevars 0 r then
34.112 + if term_contains_const c r then
34.113 + raise Compile "parameterless rewrite is caught in cycle"
34.114 + else if not (null prems) then
34.115 + raise Compile "parameterless rewrite may not be guarded"
34.116 + else
34.117 + SOME (c, r)
34.118 + else raise Compile "unbound variable on right hand side or guards of rule"
34.119 + | find_rewrite (_ :: rules) = find_rewrite rules
34.120 + fun remove_rewrite _ [] = []
34.121 + | remove_rewrite (cr as (c, r)) ((rule as (prems', PConst (c', args), r')) :: rules) =
34.122 + if c = c' then
34.123 + if null args andalso r = r' andalso null prems' then remove_rewrite cr rules
34.124 + else raise Compile "incompatible parameterless rewrites found"
34.125 + else
34.126 + rule :: remove_rewrite cr rules
34.127 + | remove_rewrite cr (r :: rs) = r :: remove_rewrite cr rs
34.128 + fun pattern_contains_const c (PConst (c', args)) = c = c' orelse exists (pattern_contains_const c) args
34.129 + | pattern_contains_const c (PVar) = false
34.130 + fun inline_rewrite (ct as (c, _)) (prems, p, r) =
34.131 + if pattern_contains_const c p then
34.132 + raise Compile "parameterless rewrite cannot be used in pattern"
34.133 + else (map (fn (Guard (a, b)) => Guard (subst_const ct a, subst_const ct b)) prems, p, subst_const ct r)
34.134 + fun inline inlined rules =
34.135 + case find_rewrite rules of
34.136 + NONE => (Inttab.make inlined, rules)
34.137 + | SOME ct =>
34.138 + let
34.139 + val rules = map (inline_rewrite ct) (remove_rewrite ct rules)
34.140 + val inlined = ct :: (map o apsnd) (subst_const ct) inlined
34.141 + in inline inlined rules end
34.142 + in
34.143 + inline [] rules
34.144 + end
34.145 +
34.146 +
34.147 +(*
34.148 + Calculate the arity, the toplevel_arity, and adjust rules so that all toplevel pattern constants have maximal arity.
34.149 + Also beta reduce the adjusted right hand side of a rule.
34.150 +*)
34.151 +fun adjust_rules rules =
34.152 + let
34.153 + val arity = fold (fn (prems, p, t) => fn arity => fold collect_guard_arity prems (collect_term_arity t (collect_pattern_arity p arity))) rules Inttab.empty
34.154 + val toplevel_arity = fold (fn (_, p, _) => fn arity => collect_pattern_toplevel_arity p arity) rules Inttab.empty
34.155 + fun arity_of c = the (Inttab.lookup arity c)
34.156 + fun test_pattern PVar = ()
34.157 + | test_pattern (PConst (c, args)) = if (length args <> arity_of c) then raise Compile ("Constant inside pattern must have maximal arity") else (map test_pattern args; ())
34.158 + fun adjust_rule (_, PVar, _) = raise Compile ("pattern may not be a variable")
34.159 + | adjust_rule (_, PConst (_, []), _) = raise Compile ("cannot deal with rewrites that take no parameters")
34.160 + | adjust_rule (rule as (prems, p as PConst (c, args),t)) =
34.161 + let
34.162 + val patternvars_counted = count_patternvars p
34.163 + fun check_fv t = check_freevars patternvars_counted t
34.164 + val _ = if not (check_fv t) then raise Compile ("unbound variables on right hand side of rule") else ()
34.165 + val _ = if not (forall (fn (Guard (a,b)) => check_fv a andalso check_fv b) prems) then raise Compile ("unbound variables in guards") else ()
34.166 + val _ = map test_pattern args
34.167 + val len = length args
34.168 + val arity = arity_of c
34.169 + val lift = nlift 0
34.170 + fun addapps_tm n t = if n=0 then t else addapps_tm (n-1) (App (t, Var (n-1)))
34.171 + fun adjust_term n t = addapps_tm n (lift n t)
34.172 + fun adjust_guard n (Guard (a,b)) = Guard (lift n a, lift n b)
34.173 + in
34.174 + if len = arity then
34.175 + rule
34.176 + else if arity >= len then
34.177 + (map (adjust_guard (arity-len)) prems, PConst (c, args @ (rep (arity-len) PVar)), adjust_term (arity-len) t)
34.178 + else (raise Compile "internal error in adjust_rule")
34.179 + end
34.180 + fun beta_rule (prems, p, t) = ((prems, p, beta t) handle Match => raise Compile "beta_rule")
34.181 + in
34.182 + (arity, toplevel_arity, map (beta_rule o adjust_rule) rules)
34.183 + end
34.184 +
34.185 +fun print_term module arity_of toplevel_arity_of pattern_var_count pattern_lazy_var_count =
34.186 +let
34.187 + fun str x = string_of_int x
34.188 + fun protect_blank s = if exists_string Symbol.is_ascii_blank s then "(" ^ s ^")" else s
34.189 + val module_prefix = (case module of NONE => "" | SOME s => s^".")
34.190 + fun print_apps d f [] = f
34.191 + | print_apps d f (a::args) = print_apps d (module_prefix^"app "^(protect_blank f)^" "^(protect_blank (print_term d a))) args
34.192 + and print_call d (App (a, b)) args = print_call d a (b::args)
34.193 + | print_call d (Const c) args =
34.194 + (case arity_of c of
34.195 + NONE => print_apps d (module_prefix^"Const "^(str c)) args
34.196 + | SOME 0 => module_prefix^"C"^(str c)
34.197 + | SOME a =>
34.198 + let
34.199 + val len = length args
34.200 + in
34.201 + if a <= len then
34.202 + let
34.203 + val strict_a = (case toplevel_arity_of c of SOME sa => sa | NONE => a)
34.204 + val _ = if strict_a > a then raise Compile "strict" else ()
34.205 + val s = module_prefix^"c"^(str c)^(implode (map (fn t => " "^(protect_blank (print_term d t))) (List.take (args, strict_a))))
34.206 + val s = s^(implode (map (fn t => " (fn () => "^print_term d t^")") (List.drop (List.take (args, a), strict_a))))
34.207 + in
34.208 + print_apps d s (List.drop (args, a))
34.209 + end
34.210 + else
34.211 + let
34.212 + fun mk_apps n t = if n = 0 then t else mk_apps (n-1) (App (t, Var (n - 1)))
34.213 + fun mk_lambdas n t = if n = 0 then t else mk_lambdas (n-1) (Abs t)
34.214 + fun append_args [] t = t
34.215 + | append_args (c::cs) t = append_args cs (App (t, c))
34.216 + in
34.217 + print_term d (mk_lambdas (a-len) (mk_apps (a-len) (nlift 0 (a-len) (append_args args (Const c)))))
34.218 + end
34.219 + end)
34.220 + | print_call d t args = print_apps d (print_term d t) args
34.221 + and print_term d (Var x) =
34.222 + if x < d then
34.223 + "b"^(str (d-x-1))
34.224 + else
34.225 + let
34.226 + val n = pattern_var_count - (x-d) - 1
34.227 + val x = "x"^(str n)
34.228 + in
34.229 + if n < pattern_var_count - pattern_lazy_var_count then
34.230 + x
34.231 + else
34.232 + "("^x^" ())"
34.233 + end
34.234 + | print_term d (Abs c) = module_prefix^"Abs (fn b"^(str d)^" => "^(print_term (d + 1) c)^")"
34.235 + | print_term d t = print_call d t []
34.236 +in
34.237 + print_term 0
34.238 +end
34.239 +
34.240 +fun section n = if n = 0 then [] else (section (n-1))@[n-1]
34.241 +
34.242 +fun print_rule gnum arity_of toplevel_arity_of (guards, p, t) =
34.243 + let
34.244 + fun str x = string_of_int x
34.245 + fun print_pattern top n PVar = (n+1, "x"^(str n))
34.246 + | print_pattern top n (PConst (c, [])) = (n, (if top then "c" else "C")^(str c)^(if top andalso gnum > 0 then "_"^(str gnum) else ""))
34.247 + | print_pattern top n (PConst (c, args)) =
34.248 + let
34.249 + val f = (if top then "c" else "C")^(str c)^(if top andalso gnum > 0 then "_"^(str gnum) else "")
34.250 + val (n, s) = print_pattern_list 0 top (n, f) args
34.251 + in
34.252 + (n, s)
34.253 + end
34.254 + and print_pattern_list' counter top (n,p) [] = if top then (n,p) else (n,p^")")
34.255 + | print_pattern_list' counter top (n, p) (t::ts) =
34.256 + let
34.257 + val (n, t) = print_pattern false n t
34.258 + in
34.259 + print_pattern_list' (counter + 1) top (n, if top then p^" (a"^(str counter)^" as ("^t^"))" else p^", "^t) ts
34.260 + end
34.261 + and print_pattern_list counter top (n, p) (t::ts) =
34.262 + let
34.263 + val (n, t) = print_pattern false n t
34.264 + in
34.265 + print_pattern_list' (counter + 1) top (n, if top then p^" (a"^(str counter)^" as ("^t^"))" else p^" ("^t) ts
34.266 + end
34.267 + val c = (case p of PConst (c, _) => c | _ => raise Match)
34.268 + val (n, pattern) = print_pattern true 0 p
34.269 + val lazy_vars = the (arity_of c) - the (toplevel_arity_of c)
34.270 + fun print_tm tm = print_term NONE arity_of toplevel_arity_of n lazy_vars tm
34.271 + fun print_guard (Guard (a,b)) = "term_eq ("^(print_tm a)^") ("^(print_tm b)^")"
34.272 + val else_branch = "c"^(str c)^"_"^(str (gnum+1))^(implode (map (fn i => " a"^(str i)) (section (the (arity_of c)))))
34.273 + fun print_guards t [] = print_tm t
34.274 + | print_guards t (g::gs) = "if ("^(print_guard g)^")"^(implode (map (fn g => " andalso ("^(print_guard g)^")") gs))^" then ("^(print_tm t)^") else "^else_branch
34.275 + in
34.276 + (if null guards then gnum else gnum+1, pattern^" = "^(print_guards t guards))
34.277 + end
34.278 +
34.279 +fun group_rules rules =
34.280 + let
34.281 + fun add_rule (r as (_, PConst (c,_), _)) groups =
34.282 + let
34.283 + val rs = (case Inttab.lookup groups c of NONE => [] | SOME rs => rs)
34.284 + in
34.285 + Inttab.update (c, r::rs) groups
34.286 + end
34.287 + | add_rule _ _ = raise Compile "internal error group_rules"
34.288 + in
34.289 + fold_rev add_rule rules Inttab.empty
34.290 + end
34.291 +
34.292 +fun sml_prog name code rules =
34.293 + let
34.294 + val buffer = Unsynchronized.ref ""
34.295 + fun write s = (buffer := (!buffer)^s)
34.296 + fun writeln s = (write s; write "\n")
34.297 + fun writelist [] = ()
34.298 + | writelist (s::ss) = (writeln s; writelist ss)
34.299 + fun str i = string_of_int i
34.300 + val (inlinetab, rules) = inline_rules rules
34.301 + val (arity, toplevel_arity, rules) = adjust_rules rules
34.302 + val rules = group_rules rules
34.303 + val constants = Inttab.keys arity
34.304 + fun arity_of c = Inttab.lookup arity c
34.305 + fun toplevel_arity_of c = Inttab.lookup toplevel_arity c
34.306 + fun rep_str s n = implode (rep n s)
34.307 + fun indexed s n = s^(str n)
34.308 + fun string_of_tuple [] = ""
34.309 + | string_of_tuple (x::xs) = "("^x^(implode (map (fn s => ", "^s) xs))^")"
34.310 + fun string_of_args [] = ""
34.311 + | string_of_args (x::xs) = x^(implode (map (fn s => " "^s) xs))
34.312 + fun default_case gnum c =
34.313 + let
34.314 + val leftargs = implode (map (indexed " x") (section (the (arity_of c))))
34.315 + val rightargs = section (the (arity_of c))
34.316 + val strict_args = (case toplevel_arity_of c of NONE => the (arity_of c) | SOME sa => sa)
34.317 + val xs = map (fn n => if n < strict_args then "x"^(str n) else "x"^(str n)^"()") rightargs
34.318 + val right = (indexed "C" c)^" "^(string_of_tuple xs)
34.319 + val message = "(\"unresolved lazy call: " ^ string_of_int c ^ "\")"
34.320 + val right = if strict_args < the (arity_of c) then "raise AM_SML.Run "^message else right
34.321 + in
34.322 + (indexed "c" c)^(if gnum > 0 then "_"^(str gnum) else "")^leftargs^" = "^right
34.323 + end
34.324 +
34.325 + fun eval_rules c =
34.326 + let
34.327 + val arity = the (arity_of c)
34.328 + val strict_arity = (case toplevel_arity_of c of NONE => arity | SOME sa => sa)
34.329 + fun eval_rule n =
34.330 + let
34.331 + val sc = string_of_int c
34.332 + val left = fold (fn i => fn s => "AbstractMachine.App ("^s^(indexed ", x" i)^")") (section n) ("AbstractMachine.Const "^sc)
34.333 + fun arg i =
34.334 + let
34.335 + val x = indexed "x" i
34.336 + val x = if i < n then "(eval bounds "^x^")" else x
34.337 + val x = if i < strict_arity then x else "(fn () => "^x^")"
34.338 + in
34.339 + x
34.340 + end
34.341 + val right = "c"^sc^" "^(string_of_args (map arg (section arity)))
34.342 + val right = fold_rev (fn i => fn s => "Abs (fn "^(indexed "x" i)^" => "^s^")") (List.drop (section arity, n)) right
34.343 + val right = if arity > 0 then right else "C"^sc
34.344 + in
34.345 + " | eval bounds ("^left^") = "^right
34.346 + end
34.347 + in
34.348 + map eval_rule (rev (section (arity + 1)))
34.349 + end
34.350 +
34.351 + fun convert_computed_rules (c: int) : string list =
34.352 + let
34.353 + val arity = the (arity_of c)
34.354 + fun eval_rule () =
34.355 + let
34.356 + val sc = string_of_int c
34.357 + val left = fold (fn i => fn s => "AbstractMachine.App ("^s^(indexed ", x" i)^")") (section arity) ("AbstractMachine.Const "^sc)
34.358 + fun arg i = "(convert_computed "^(indexed "x" i)^")"
34.359 + val right = "C"^sc^" "^(string_of_tuple (map arg (section arity)))
34.360 + val right = if arity > 0 then right else "C"^sc
34.361 + in
34.362 + " | convert_computed ("^left^") = "^right
34.363 + end
34.364 + in
34.365 + [eval_rule ()]
34.366 + end
34.367 +
34.368 + fun mk_constr_type_args n = if n > 0 then " of Term "^(rep_str " * Term" (n-1)) else ""
34.369 + val _ = writelist [
34.370 + "structure "^name^" = struct",
34.371 + "",
34.372 + "datatype Term = Const of int | App of Term * Term | Abs of (Term -> Term)",
34.373 + " "^(implode (map (fn c => " | C"^(str c)^(mk_constr_type_args (the (arity_of c)))) constants)),
34.374 + ""]
34.375 + fun make_constr c argprefix = "(C"^(str c)^" "^(string_of_tuple (map (fn i => argprefix^(str i)) (section (the (arity_of c)))))^")"
34.376 + fun make_term_eq c = " | term_eq "^(make_constr c "a")^" "^(make_constr c "b")^" = "^
34.377 + (case the (arity_of c) of
34.378 + 0 => "true"
34.379 + | n =>
34.380 + let
34.381 + val eqs = map (fn i => "term_eq a"^(str i)^" b"^(str i)) (section n)
34.382 + val (eq, eqs) = (List.hd eqs, map (fn s => " andalso "^s) (List.tl eqs))
34.383 + in
34.384 + eq^(implode eqs)
34.385 + end)
34.386 + val _ = writelist [
34.387 + "fun term_eq (Const c1) (Const c2) = (c1 = c2)",
34.388 + " | term_eq (App (a1,a2)) (App (b1,b2)) = term_eq a1 b1 andalso term_eq a2 b2"]
34.389 + val _ = writelist (map make_term_eq constants)
34.390 + val _ = writelist [
34.391 + " | term_eq _ _ = false",
34.392 + ""
34.393 + ]
34.394 + val _ = writelist [
34.395 + "fun app (Abs a) b = a b",
34.396 + " | app a b = App (a, b)",
34.397 + ""]
34.398 + fun defcase gnum c = (case arity_of c of NONE => [] | SOME a => if a > 0 then [default_case gnum c] else [])
34.399 + fun writefundecl [] = ()
34.400 + | writefundecl (x::xs) = writelist ((("and "^x)::(map (fn s => " | "^s) xs)))
34.401 + fun list_group c = (case Inttab.lookup rules c of
34.402 + NONE => [defcase 0 c]
34.403 + | SOME rs =>
34.404 + let
34.405 + val rs =
34.406 + fold
34.407 + (fn r =>
34.408 + fn rs =>
34.409 + let
34.410 + val (gnum, l, rs) =
34.411 + (case rs of
34.412 + [] => (0, [], [])
34.413 + | (gnum, l)::rs => (gnum, l, rs))
34.414 + val (gnum', r) = print_rule gnum arity_of toplevel_arity_of r
34.415 + in
34.416 + if gnum' = gnum then
34.417 + (gnum, r::l)::rs
34.418 + else
34.419 + let
34.420 + val args = implode (map (fn i => " a"^(str i)) (section (the (arity_of c))))
34.421 + fun gnumc g = if g > 0 then "c"^(str c)^"_"^(str g)^args else "c"^(str c)^args
34.422 + val s = gnumc (gnum) ^ " = " ^ gnumc (gnum')
34.423 + in
34.424 + (gnum', [])::(gnum, s::r::l)::rs
34.425 + end
34.426 + end)
34.427 + rs []
34.428 + val rs = (case rs of [] => [(0,defcase 0 c)] | (gnum,l)::rs => (gnum, (defcase gnum c)@l)::rs)
34.429 + in
34.430 + rev (map (fn z => rev (snd z)) rs)
34.431 + end)
34.432 + val _ = map (fn z => (map writefundecl z; writeln "")) (map list_group constants)
34.433 + val _ = writelist [
34.434 + "fun convert (Const i) = AM_SML.Const i",
34.435 + " | convert (App (a, b)) = AM_SML.App (convert a, convert b)",
34.436 + " | convert (Abs _) = raise AM_SML.Run \"no abstraction in result allowed\""]
34.437 + fun make_convert c =
34.438 + let
34.439 + val args = map (indexed "a") (section (the (arity_of c)))
34.440 + val leftargs =
34.441 + case args of
34.442 + [] => ""
34.443 + | (x::xs) => "("^x^(implode (map (fn s => ", "^s) xs))^")"
34.444 + val args = map (indexed "convert a") (section (the (arity_of c)))
34.445 + val right = fold (fn x => fn s => "AM_SML.App ("^s^", "^x^")") args ("AM_SML.Const "^(str c))
34.446 + in
34.447 + " | convert (C"^(str c)^" "^leftargs^") = "^right
34.448 + end
34.449 + val _ = writelist (map make_convert constants)
34.450 + val _ = writelist [
34.451 + "",
34.452 + "fun convert_computed (AbstractMachine.Abs b) = raise AM_SML.Run \"no abstraction in convert_computed allowed\"",
34.453 + " | convert_computed (AbstractMachine.Var i) = raise AM_SML.Run \"no bound variables in convert_computed allowed\""]
34.454 + val _ = map (writelist o convert_computed_rules) constants
34.455 + val _ = writelist [
34.456 + " | convert_computed (AbstractMachine.Const c) = Const c",
34.457 + " | convert_computed (AbstractMachine.App (a, b)) = App (convert_computed a, convert_computed b)",
34.458 + " | convert_computed (AbstractMachine.Computed a) = raise AM_SML.Run \"no nesting in convert_computed allowed\""]
34.459 + val _ = writelist [
34.460 + "",
34.461 + "fun eval bounds (AbstractMachine.Abs m) = Abs (fn b => eval (b::bounds) m)",
34.462 + " | eval bounds (AbstractMachine.Var i) = AM_SML.list_nth (bounds, i)"]
34.463 + val _ = map (writelist o eval_rules) constants
34.464 + val _ = writelist [
34.465 + " | eval bounds (AbstractMachine.App (a, b)) = app (eval bounds a) (eval bounds b)",
34.466 + " | eval bounds (AbstractMachine.Const c) = Const c",
34.467 + " | eval bounds (AbstractMachine.Computed t) = convert_computed t"]
34.468 + val _ = writelist [
34.469 + "",
34.470 + "fun export term = AM_SML.save_result (\""^code^"\", convert term)",
34.471 + "",
34.472 + "val _ = AM_SML.set_compiled_rewriter (fn t => (convert (eval [] t)))",
34.473 + "",
34.474 + "end"]
34.475 + in
34.476 + (inlinetab, !buffer)
34.477 + end
34.478 +
34.479 +val guid_counter = Unsynchronized.ref 0
34.480 +fun get_guid () =
34.481 + let
34.482 + val c = !guid_counter
34.483 + val _ = guid_counter := !guid_counter + 1
34.484 + in
34.485 + string_of_int (Time.toMicroseconds (Time.now ())) ^ string_of_int c
34.486 + end
34.487 +
34.488 +
34.489 +fun writeTextFile name s = File.write (Path.explode name) s
34.490 +
34.491 +fun use_source src = use_text ML_Env.local_context (1, "") false src
34.492 +
34.493 +fun compile rules =
34.494 + let
34.495 + val guid = get_guid ()
34.496 + val code = Real.toString (random ())
34.497 + val name = "AMSML_"^guid
34.498 + val (inlinetab, source) = sml_prog name code rules
34.499 + val _ = case !dump_output of NONE => () | SOME p => writeTextFile p source
34.500 + val _ = compiled_rewriter := NONE
34.501 + val _ = use_source source
34.502 + in
34.503 + case !compiled_rewriter of
34.504 + NONE => raise Compile "broken link to compiled function"
34.505 + | SOME compiled_fun => (inlinetab, compiled_fun)
34.506 + end
34.507 +
34.508 +fun run (inlinetab, compiled_fun) t =
34.509 + let
34.510 + val _ = if check_freevars 0 t then () else raise Run ("can only compute closed terms")
34.511 + fun inline (Const c) = (case Inttab.lookup inlinetab c of NONE => Const c | SOME t => t)
34.512 + | inline (Var i) = Var i
34.513 + | inline (App (a, b)) = App (inline a, inline b)
34.514 + | inline (Abs m) = Abs (inline m)
34.515 + | inline (Computed t) = Computed t
34.516 + in
34.517 + compiled_fun (beta (inline t))
34.518 + end
34.519 +
34.520 +end
35.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
35.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/compute.ML Sat Mar 17 12:52:40 2012 +0100
35.3 @@ -0,0 +1,653 @@
35.4 +(* Title: HOL/Matrix/Compute_Oracle/compute.ML
35.5 + Author: Steven Obua
35.6 +*)
35.7 +
35.8 +signature COMPUTE = sig
35.9 +
35.10 + type computer
35.11 + type theorem
35.12 + type naming = int -> string
35.13 +
35.14 + datatype machine = BARRAS | BARRAS_COMPILED | HASKELL | SML
35.15 +
35.16 + (* Functions designated with a ! in front of them actually update the computer parameter *)
35.17 +
35.18 + exception Make of string
35.19 + val make : machine -> theory -> thm list -> computer
35.20 + val make_with_cache : machine -> theory -> term list -> thm list -> computer
35.21 + val theory_of : computer -> theory
35.22 + val hyps_of : computer -> term list
35.23 + val shyps_of : computer -> sort list
35.24 + (* ! *) val update : computer -> thm list -> unit
35.25 + (* ! *) val update_with_cache : computer -> term list -> thm list -> unit
35.26 +
35.27 + (* ! *) val set_naming : computer -> naming -> unit
35.28 + val naming_of : computer -> naming
35.29 +
35.30 + exception Compute of string
35.31 + val simplify : computer -> theorem -> thm
35.32 + val rewrite : computer -> cterm -> thm
35.33 +
35.34 + val make_theorem : computer -> thm -> string list -> theorem
35.35 + (* ! *) val instantiate : computer -> (string * cterm) list -> theorem -> theorem
35.36 + (* ! *) val evaluate_prem : computer -> int -> theorem -> theorem
35.37 + (* ! *) val modus_ponens : computer -> int -> thm -> theorem -> theorem
35.38 +
35.39 +end
35.40 +
35.41 +structure Compute :> COMPUTE = struct
35.42 +
35.43 +open Report;
35.44 +
35.45 +datatype machine = BARRAS | BARRAS_COMPILED | HASKELL | SML
35.46 +
35.47 +(* Terms are mapped to integer codes *)
35.48 +structure Encode :>
35.49 +sig
35.50 + type encoding
35.51 + val empty : encoding
35.52 + val insert : term -> encoding -> int * encoding
35.53 + val lookup_code : term -> encoding -> int option
35.54 + val lookup_term : int -> encoding -> term option
35.55 + val remove_code : int -> encoding -> encoding
35.56 + val remove_term : term -> encoding -> encoding
35.57 +end
35.58 +=
35.59 +struct
35.60 +
35.61 +type encoding = int * (int Termtab.table) * (term Inttab.table)
35.62 +
35.63 +val empty = (0, Termtab.empty, Inttab.empty)
35.64 +
35.65 +fun insert t (e as (count, term2int, int2term)) =
35.66 + (case Termtab.lookup term2int t of
35.67 + NONE => (count, (count+1, Termtab.update_new (t, count) term2int, Inttab.update_new (count, t) int2term))
35.68 + | SOME code => (code, e))
35.69 +
35.70 +fun lookup_code t (_, term2int, _) = Termtab.lookup term2int t
35.71 +
35.72 +fun lookup_term c (_, _, int2term) = Inttab.lookup int2term c
35.73 +
35.74 +fun remove_code c (e as (count, term2int, int2term)) =
35.75 + (case lookup_term c e of NONE => e | SOME t => (count, Termtab.delete t term2int, Inttab.delete c int2term))
35.76 +
35.77 +fun remove_term t (e as (count, term2int, int2term)) =
35.78 + (case lookup_code t e of NONE => e | SOME c => (count, Termtab.delete t term2int, Inttab.delete c int2term))
35.79 +
35.80 +end
35.81 +
35.82 +exception Make of string;
35.83 +exception Compute of string;
35.84 +
35.85 +local
35.86 + fun make_constant t encoding =
35.87 + let
35.88 + val (code, encoding) = Encode.insert t encoding
35.89 + in
35.90 + (encoding, AbstractMachine.Const code)
35.91 + end
35.92 +in
35.93 +
35.94 +fun remove_types encoding t =
35.95 + case t of
35.96 + Var _ => make_constant t encoding
35.97 + | Free _ => make_constant t encoding
35.98 + | Const _ => make_constant t encoding
35.99 + | Abs (_, _, t') =>
35.100 + let val (encoding, t'') = remove_types encoding t' in
35.101 + (encoding, AbstractMachine.Abs t'')
35.102 + end
35.103 + | a $ b =>
35.104 + let
35.105 + val (encoding, a) = remove_types encoding a
35.106 + val (encoding, b) = remove_types encoding b
35.107 + in
35.108 + (encoding, AbstractMachine.App (a,b))
35.109 + end
35.110 + | Bound b => (encoding, AbstractMachine.Var b)
35.111 +end
35.112 +
35.113 +local
35.114 + fun type_of (Free (_, ty)) = ty
35.115 + | type_of (Const (_, ty)) = ty
35.116 + | type_of (Var (_, ty)) = ty
35.117 + | type_of _ = raise Fail "infer_types: type_of error"
35.118 +in
35.119 +fun infer_types naming encoding =
35.120 + let
35.121 + fun infer_types _ bounds _ (AbstractMachine.Var v) = (Bound v, nth bounds v)
35.122 + | infer_types _ bounds _ (AbstractMachine.Const code) =
35.123 + let
35.124 + val c = the (Encode.lookup_term code encoding)
35.125 + in
35.126 + (c, type_of c)
35.127 + end
35.128 + | infer_types level bounds _ (AbstractMachine.App (a, b)) =
35.129 + let
35.130 + val (a, aty) = infer_types level bounds NONE a
35.131 + val (adom, arange) =
35.132 + case aty of
35.133 + Type ("fun", [dom, range]) => (dom, range)
35.134 + | _ => raise Fail "infer_types: function type expected"
35.135 + val (b, _) = infer_types level bounds (SOME adom) b
35.136 + in
35.137 + (a $ b, arange)
35.138 + end
35.139 + | infer_types level bounds (SOME (ty as Type ("fun", [dom, range]))) (AbstractMachine.Abs m) =
35.140 + let
35.141 + val (m, _) = infer_types (level+1) (dom::bounds) (SOME range) m
35.142 + in
35.143 + (Abs (naming level, dom, m), ty)
35.144 + end
35.145 + | infer_types _ _ NONE (AbstractMachine.Abs _) =
35.146 + raise Fail "infer_types: cannot infer type of abstraction"
35.147 +
35.148 + fun infer ty term =
35.149 + let
35.150 + val (term', _) = infer_types 0 [] (SOME ty) term
35.151 + in
35.152 + term'
35.153 + end
35.154 + in
35.155 + infer
35.156 + end
35.157 +end
35.158 +
35.159 +datatype prog =
35.160 + ProgBarras of AM_Interpreter.program
35.161 + | ProgBarrasC of AM_Compiler.program
35.162 + | ProgHaskell of AM_GHC.program
35.163 + | ProgSML of AM_SML.program
35.164 +
35.165 +fun machine_of_prog (ProgBarras _) = BARRAS
35.166 + | machine_of_prog (ProgBarrasC _) = BARRAS_COMPILED
35.167 + | machine_of_prog (ProgHaskell _) = HASKELL
35.168 + | machine_of_prog (ProgSML _) = SML
35.169 +
35.170 +type naming = int -> string
35.171 +
35.172 +fun default_naming i = "v_" ^ string_of_int i
35.173 +
35.174 +datatype computer = Computer of
35.175 + (theory_ref * Encode.encoding * term list * unit Sorttab.table * prog * unit Unsynchronized.ref * naming)
35.176 + option Unsynchronized.ref
35.177 +
35.178 +fun theory_of (Computer (Unsynchronized.ref (SOME (rthy,_,_,_,_,_,_)))) = Theory.deref rthy
35.179 +fun hyps_of (Computer (Unsynchronized.ref (SOME (_,_,hyps,_,_,_,_)))) = hyps
35.180 +fun shyps_of (Computer (Unsynchronized.ref (SOME (_,_,_,shyptable,_,_,_)))) = Sorttab.keys (shyptable)
35.181 +fun shyptab_of (Computer (Unsynchronized.ref (SOME (_,_,_,shyptable,_,_,_)))) = shyptable
35.182 +fun stamp_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,_,stamp,_)))) = stamp
35.183 +fun prog_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,prog,_,_)))) = prog
35.184 +fun encoding_of (Computer (Unsynchronized.ref (SOME (_,encoding,_,_,_,_,_)))) = encoding
35.185 +fun set_encoding (Computer (r as Unsynchronized.ref (SOME (p1,_,p2,p3,p4,p5,p6)))) encoding' =
35.186 + (r := SOME (p1,encoding',p2,p3,p4,p5,p6))
35.187 +fun naming_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,_,_,n)))) = n
35.188 +fun set_naming (Computer (r as Unsynchronized.ref (SOME (p1,p2,p3,p4,p5,p6,_)))) naming'=
35.189 + (r := SOME (p1,p2,p3,p4,p5,p6,naming'))
35.190 +
35.191 +fun ref_of (Computer r) = r
35.192 +
35.193 +datatype cthm = ComputeThm of term list * sort list * term
35.194 +
35.195 +fun thm2cthm th =
35.196 + let
35.197 + val {hyps, prop, tpairs, shyps, ...} = Thm.rep_thm th
35.198 + val _ = if not (null tpairs) then raise Make "theorems may not contain tpairs" else ()
35.199 + in
35.200 + ComputeThm (hyps, shyps, prop)
35.201 + end
35.202 +
35.203 +fun make_internal machine thy stamp encoding cache_pattern_terms raw_ths =
35.204 + let
35.205 + fun transfer (x:thm) = Thm.transfer thy x
35.206 + val ths = map (thm2cthm o Thm.strip_shyps o transfer) raw_ths
35.207 +
35.208 + fun make_pattern encoding n vars (AbstractMachine.Abs _) =
35.209 + raise (Make "no lambda abstractions allowed in pattern")
35.210 + | make_pattern encoding n vars (AbstractMachine.Var _) =
35.211 + raise (Make "no bound variables allowed in pattern")
35.212 + | make_pattern encoding n vars (AbstractMachine.Const code) =
35.213 + (case the (Encode.lookup_term code encoding) of
35.214 + Var _ => ((n+1, Inttab.update_new (code, n) vars, AbstractMachine.PVar)
35.215 + handle Inttab.DUP _ => raise (Make "no duplicate variable in pattern allowed"))
35.216 + | _ => (n, vars, AbstractMachine.PConst (code, [])))
35.217 + | make_pattern encoding n vars (AbstractMachine.App (a, b)) =
35.218 + let
35.219 + val (n, vars, pa) = make_pattern encoding n vars a
35.220 + val (n, vars, pb) = make_pattern encoding n vars b
35.221 + in
35.222 + case pa of
35.223 + AbstractMachine.PVar =>
35.224 + raise (Make "patterns may not start with a variable")
35.225 + | AbstractMachine.PConst (c, args) =>
35.226 + (n, vars, AbstractMachine.PConst (c, args@[pb]))
35.227 + end
35.228 +
35.229 + fun thm2rule (encoding, hyptable, shyptable) th =
35.230 + let
35.231 + val (ComputeThm (hyps, shyps, prop)) = th
35.232 + val hyptable = fold (fn h => Termtab.update (h, ())) hyps hyptable
35.233 + val shyptable = fold (fn sh => Sorttab.update (sh, ())) shyps shyptable
35.234 + val (prems, prop) = (Logic.strip_imp_prems prop, Logic.strip_imp_concl prop)
35.235 + val (a, b) = Logic.dest_equals prop
35.236 + handle TERM _ => raise (Make "theorems must be meta-level equations (with optional guards)")
35.237 + val a = Envir.eta_contract a
35.238 + val b = Envir.eta_contract b
35.239 + val prems = map Envir.eta_contract prems
35.240 +
35.241 + val (encoding, left) = remove_types encoding a
35.242 + val (encoding, right) = remove_types encoding b
35.243 + fun remove_types_of_guard encoding g =
35.244 + (let
35.245 + val (t1, t2) = Logic.dest_equals g
35.246 + val (encoding, t1) = remove_types encoding t1
35.247 + val (encoding, t2) = remove_types encoding t2
35.248 + in
35.249 + (encoding, AbstractMachine.Guard (t1, t2))
35.250 + end handle TERM _ => raise (Make "guards must be meta-level equations"))
35.251 + val (encoding, prems) = fold_rev (fn p => fn (encoding, ps) => let val (e, p) = remove_types_of_guard encoding p in (e, p::ps) end) prems (encoding, [])
35.252 +
35.253 + (* Principally, a check should be made here to see if the (meta-) hyps contain any of the variables of the rule.
35.254 + As it is, all variables of the rule are schematic, and there are no schematic variables in meta-hyps, therefore
35.255 + this check can be left out. *)
35.256 +
35.257 + val (vcount, vars, pattern) = make_pattern encoding 0 Inttab.empty left
35.258 + val _ = (case pattern of
35.259 + AbstractMachine.PVar =>
35.260 + raise (Make "patterns may not start with a variable")
35.261 + | _ => ())
35.262 +
35.263 + (* finally, provide a function for renaming the
35.264 + pattern bound variables on the right hand side *)
35.265 +
35.266 + fun rename level vars (var as AbstractMachine.Var _) = var
35.267 + | rename level vars (c as AbstractMachine.Const code) =
35.268 + (case Inttab.lookup vars code of
35.269 + NONE => c
35.270 + | SOME n => AbstractMachine.Var (vcount-n-1+level))
35.271 + | rename level vars (AbstractMachine.App (a, b)) =
35.272 + AbstractMachine.App (rename level vars a, rename level vars b)
35.273 + | rename level vars (AbstractMachine.Abs m) =
35.274 + AbstractMachine.Abs (rename (level+1) vars m)
35.275 +
35.276 + fun rename_guard (AbstractMachine.Guard (a,b)) =
35.277 + AbstractMachine.Guard (rename 0 vars a, rename 0 vars b)
35.278 + in
35.279 + ((encoding, hyptable, shyptable), (map rename_guard prems, pattern, rename 0 vars right))
35.280 + end
35.281 +
35.282 + val ((encoding, hyptable, shyptable), rules) =
35.283 + fold_rev (fn th => fn (encoding_hyptable, rules) =>
35.284 + let
35.285 + val (encoding_hyptable, rule) = thm2rule encoding_hyptable th
35.286 + in (encoding_hyptable, rule::rules) end)
35.287 + ths ((encoding, Termtab.empty, Sorttab.empty), [])
35.288 +
35.289 + fun make_cache_pattern t (encoding, cache_patterns) =
35.290 + let
35.291 + val (encoding, a) = remove_types encoding t
35.292 + val (_,_,p) = make_pattern encoding 0 Inttab.empty a
35.293 + in
35.294 + (encoding, p::cache_patterns)
35.295 + end
35.296 +
35.297 + val (encoding, _) = fold_rev make_cache_pattern cache_pattern_terms (encoding, [])
35.298 +
35.299 + val prog =
35.300 + case machine of
35.301 + BARRAS => ProgBarras (AM_Interpreter.compile rules)
35.302 + | BARRAS_COMPILED => ProgBarrasC (AM_Compiler.compile rules)
35.303 + | HASKELL => ProgHaskell (AM_GHC.compile rules)
35.304 + | SML => ProgSML (AM_SML.compile rules)
35.305 +
35.306 + fun has_witness s = not (null (Sign.witness_sorts thy [] [s]))
35.307 +
35.308 + val shyptable = fold Sorttab.delete (filter has_witness (Sorttab.keys (shyptable))) shyptable
35.309 +
35.310 + in (Theory.check_thy thy, encoding, Termtab.keys hyptable, shyptable, prog, stamp, default_naming) end
35.311 +
35.312 +fun make_with_cache machine thy cache_patterns raw_thms =
35.313 + Computer (Unsynchronized.ref (SOME (make_internal machine thy (Unsynchronized.ref ()) Encode.empty cache_patterns raw_thms)))
35.314 +
35.315 +fun make machine thy raw_thms = make_with_cache machine thy [] raw_thms
35.316 +
35.317 +fun update_with_cache computer cache_patterns raw_thms =
35.318 + let
35.319 + val c = make_internal (machine_of_prog (prog_of computer)) (theory_of computer) (stamp_of computer)
35.320 + (encoding_of computer) cache_patterns raw_thms
35.321 + val _ = (ref_of computer) := SOME c
35.322 + in
35.323 + ()
35.324 + end
35.325 +
35.326 +fun update computer raw_thms = update_with_cache computer [] raw_thms
35.327 +
35.328 +fun runprog (ProgBarras p) = AM_Interpreter.run p
35.329 + | runprog (ProgBarrasC p) = AM_Compiler.run p
35.330 + | runprog (ProgHaskell p) = AM_GHC.run p
35.331 + | runprog (ProgSML p) = AM_SML.run p
35.332 +
35.333 +(* ------------------------------------------------------------------------------------- *)
35.334 +(* An oracle for exporting theorems; must only be accessible from inside this structure! *)
35.335 +(* ------------------------------------------------------------------------------------- *)
35.336 +
35.337 +fun merge_hyps hyps1 hyps2 =
35.338 +let
35.339 + fun add hyps tab = fold (fn h => fn tab => Termtab.update (h, ()) tab) hyps tab
35.340 +in
35.341 + Termtab.keys (add hyps2 (add hyps1 Termtab.empty))
35.342 +end
35.343 +
35.344 +fun add_shyps shyps tab = fold (fn h => fn tab => Sorttab.update (h, ()) tab) shyps tab
35.345 +
35.346 +fun merge_shyps shyps1 shyps2 = Sorttab.keys (add_shyps shyps2 (add_shyps shyps1 Sorttab.empty))
35.347 +
35.348 +val (_, export_oracle) = Context.>>> (Context.map_theory_result
35.349 + (Thm.add_oracle (@{binding compute}, fn (thy, hyps, shyps, prop) =>
35.350 + let
35.351 + val shyptab = add_shyps shyps Sorttab.empty
35.352 + fun delete s shyptab = Sorttab.delete s shyptab handle Sorttab.UNDEF _ => shyptab
35.353 + fun delete_term t shyptab = fold delete (Sorts.insert_term t []) shyptab
35.354 + fun has_witness s = not (null (Sign.witness_sorts thy [] [s]))
35.355 + val shyptab = fold Sorttab.delete (filter has_witness (Sorttab.keys (shyptab))) shyptab
35.356 + val shyps = if Sorttab.is_empty shyptab then [] else Sorttab.keys (fold delete_term (prop::hyps) shyptab)
35.357 + val _ =
35.358 + if not (null shyps) then
35.359 + raise Compute ("dangling sort hypotheses: " ^
35.360 + commas (map (Syntax.string_of_sort_global thy) shyps))
35.361 + else ()
35.362 + in
35.363 + Thm.cterm_of thy (fold_rev (fn hyp => fn p => Logic.mk_implies (hyp, p)) hyps prop)
35.364 + end)));
35.365 +
35.366 +fun export_thm thy hyps shyps prop =
35.367 + let
35.368 + val th = export_oracle (thy, hyps, shyps, prop)
35.369 + val hyps = map (fn h => Thm.assume (cterm_of thy h)) hyps
35.370 + in
35.371 + fold (fn h => fn p => Thm.implies_elim p h) hyps th
35.372 + end
35.373 +
35.374 +(* --------- Rewrite ----------- *)
35.375 +
35.376 +fun rewrite computer ct =
35.377 + let
35.378 + val thy = Thm.theory_of_cterm ct
35.379 + val {t=t',T=ty,...} = rep_cterm ct
35.380 + val _ = Theory.assert_super (theory_of computer) thy
35.381 + val naming = naming_of computer
35.382 + val (encoding, t) = remove_types (encoding_of computer) t'
35.383 + val t = runprog (prog_of computer) t
35.384 + val t = infer_types naming encoding ty t
35.385 + val eq = Logic.mk_equals (t', t)
35.386 + in
35.387 + export_thm thy (hyps_of computer) (Sorttab.keys (shyptab_of computer)) eq
35.388 + end
35.389 +
35.390 +(* --------- Simplify ------------ *)
35.391 +
35.392 +datatype prem = EqPrem of AbstractMachine.term * AbstractMachine.term * Term.typ * int
35.393 + | Prem of AbstractMachine.term
35.394 +datatype theorem = Theorem of theory_ref * unit Unsynchronized.ref * (int * typ) Symtab.table * (AbstractMachine.term option) Inttab.table
35.395 + * prem list * AbstractMachine.term * term list * sort list
35.396 +
35.397 +
35.398 +exception ParamSimplify of computer * theorem
35.399 +
35.400 +fun make_theorem computer th vars =
35.401 +let
35.402 + val _ = Theory.assert_super (theory_of computer) (theory_of_thm th)
35.403 +
35.404 + val (ComputeThm (hyps, shyps, prop)) = thm2cthm th
35.405 +
35.406 + val encoding = encoding_of computer
35.407 +
35.408 + (* variables in the theorem are identified upfront *)
35.409 + fun collect_vars (Abs (_, _, t)) tab = collect_vars t tab
35.410 + | collect_vars (a $ b) tab = collect_vars b (collect_vars a tab)
35.411 + | collect_vars (Const _) tab = tab
35.412 + | collect_vars (Free _) tab = tab
35.413 + | collect_vars (Var ((s, i), ty)) tab =
35.414 + if List.find (fn x => x=s) vars = NONE then
35.415 + tab
35.416 + else
35.417 + (case Symtab.lookup tab s of
35.418 + SOME ((s',i'),ty') =>
35.419 + if s' <> s orelse i' <> i orelse ty <> ty' then
35.420 + raise Compute ("make_theorem: variable name '"^s^"' is not unique")
35.421 + else
35.422 + tab
35.423 + | NONE => Symtab.update (s, ((s, i), ty)) tab)
35.424 + val vartab = collect_vars prop Symtab.empty
35.425 + fun encodevar (s, t as (_, ty)) (encoding, tab) =
35.426 + let
35.427 + val (x, encoding) = Encode.insert (Var t) encoding
35.428 + in
35.429 + (encoding, Symtab.update (s, (x, ty)) tab)
35.430 + end
35.431 + val (encoding, vartab) = Symtab.fold encodevar vartab (encoding, Symtab.empty)
35.432 + val varsubst = Inttab.make (map (fn (_, (x, _)) => (x, NONE)) (Symtab.dest vartab))
35.433 +
35.434 + (* make the premises and the conclusion *)
35.435 + fun mk_prem encoding t =
35.436 + (let
35.437 + val (a, b) = Logic.dest_equals t
35.438 + val ty = type_of a
35.439 + val (encoding, a) = remove_types encoding a
35.440 + val (encoding, b) = remove_types encoding b
35.441 + val (eq, encoding) = Encode.insert (Const ("==", ty --> ty --> @{typ "prop"})) encoding
35.442 + in
35.443 + (encoding, EqPrem (a, b, ty, eq))
35.444 + end handle TERM _ => let val (encoding, t) = remove_types encoding t in (encoding, Prem t) end)
35.445 + val (encoding, prems) =
35.446 + (fold_rev (fn t => fn (encoding, l) =>
35.447 + case mk_prem encoding t of
35.448 + (encoding, t) => (encoding, t::l)) (Logic.strip_imp_prems prop) (encoding, []))
35.449 + val (encoding, concl) = remove_types encoding (Logic.strip_imp_concl prop)
35.450 + val _ = set_encoding computer encoding
35.451 +in
35.452 + Theorem (Theory.check_thy (theory_of_thm th), stamp_of computer, vartab, varsubst,
35.453 + prems, concl, hyps, shyps)
35.454 +end
35.455 +
35.456 +fun theory_of_theorem (Theorem (rthy,_,_,_,_,_,_,_)) = Theory.deref rthy
35.457 +fun update_theory thy (Theorem (_,p0,p1,p2,p3,p4,p5,p6)) =
35.458 + Theorem (Theory.check_thy thy,p0,p1,p2,p3,p4,p5,p6)
35.459 +fun stamp_of_theorem (Theorem (_,s, _, _, _, _, _, _)) = s
35.460 +fun vartab_of_theorem (Theorem (_,_,vt,_,_,_,_,_)) = vt
35.461 +fun varsubst_of_theorem (Theorem (_,_,_,vs,_,_,_,_)) = vs
35.462 +fun update_varsubst vs (Theorem (p0,p1,p2,_,p3,p4,p5,p6)) = Theorem (p0,p1,p2,vs,p3,p4,p5,p6)
35.463 +fun prems_of_theorem (Theorem (_,_,_,_,prems,_,_,_)) = prems
35.464 +fun update_prems prems (Theorem (p0,p1,p2,p3,_,p4,p5,p6)) = Theorem (p0,p1,p2,p3,prems,p4,p5,p6)
35.465 +fun concl_of_theorem (Theorem (_,_,_,_,_,concl,_,_)) = concl
35.466 +fun hyps_of_theorem (Theorem (_,_,_,_,_,_,hyps,_)) = hyps
35.467 +fun update_hyps hyps (Theorem (p0,p1,p2,p3,p4,p5,_,p6)) = Theorem (p0,p1,p2,p3,p4,p5,hyps,p6)
35.468 +fun shyps_of_theorem (Theorem (_,_,_,_,_,_,_,shyps)) = shyps
35.469 +fun update_shyps shyps (Theorem (p0,p1,p2,p3,p4,p5,p6,_)) = Theorem (p0,p1,p2,p3,p4,p5,p6,shyps)
35.470 +
35.471 +fun check_compatible computer th s =
35.472 + if stamp_of computer <> stamp_of_theorem th then
35.473 + raise Compute (s^": computer and theorem are incompatible")
35.474 + else ()
35.475 +
35.476 +fun instantiate computer insts th =
35.477 +let
35.478 + val _ = check_compatible computer th
35.479 +
35.480 + val thy = theory_of computer
35.481 +
35.482 + val vartab = vartab_of_theorem th
35.483 +
35.484 + fun rewrite computer t =
35.485 + let
35.486 + val (encoding, t) = remove_types (encoding_of computer) t
35.487 + val t = runprog (prog_of computer) t
35.488 + val _ = set_encoding computer encoding
35.489 + in
35.490 + t
35.491 + end
35.492 +
35.493 + fun assert_varfree vs t =
35.494 + if AbstractMachine.forall_consts (fn x => Inttab.lookup vs x = NONE) t then
35.495 + ()
35.496 + else
35.497 + raise Compute "instantiate: assert_varfree failed"
35.498 +
35.499 + fun assert_closed t =
35.500 + if AbstractMachine.closed t then
35.501 + ()
35.502 + else
35.503 + raise Compute "instantiate: not a closed term"
35.504 +
35.505 + fun compute_inst (s, ct) vs =
35.506 + let
35.507 + val _ = Theory.assert_super (theory_of_cterm ct) thy
35.508 + val ty = typ_of (ctyp_of_term ct)
35.509 + in
35.510 + (case Symtab.lookup vartab s of
35.511 + NONE => raise Compute ("instantiate: variable '"^s^"' not found in theorem")
35.512 + | SOME (x, ty') =>
35.513 + (case Inttab.lookup vs x of
35.514 + SOME (SOME _) => raise Compute ("instantiate: variable '"^s^"' has already been instantiated")
35.515 + | SOME NONE =>
35.516 + if ty <> ty' then
35.517 + raise Compute ("instantiate: wrong type for variable '"^s^"'")
35.518 + else
35.519 + let
35.520 + val t = rewrite computer (term_of ct)
35.521 + val _ = assert_varfree vs t
35.522 + val _ = assert_closed t
35.523 + in
35.524 + Inttab.update (x, SOME t) vs
35.525 + end
35.526 + | NONE => raise Compute "instantiate: internal error"))
35.527 + end
35.528 +
35.529 + val vs = fold compute_inst insts (varsubst_of_theorem th)
35.530 +in
35.531 + update_varsubst vs th
35.532 +end
35.533 +
35.534 +fun match_aterms subst =
35.535 + let
35.536 + exception no_match
35.537 + open AbstractMachine
35.538 + fun match subst (b as (Const c)) a =
35.539 + if a = b then subst
35.540 + else
35.541 + (case Inttab.lookup subst c of
35.542 + SOME (SOME a') => if a=a' then subst else raise no_match
35.543 + | SOME NONE => if AbstractMachine.closed a then
35.544 + Inttab.update (c, SOME a) subst
35.545 + else raise no_match
35.546 + | NONE => raise no_match)
35.547 + | match subst (b as (Var _)) a = if a=b then subst else raise no_match
35.548 + | match subst (App (u, v)) (App (u', v')) = match (match subst u u') v v'
35.549 + | match subst (Abs u) (Abs u') = match subst u u'
35.550 + | match subst _ _ = raise no_match
35.551 + in
35.552 + fn b => fn a => (SOME (match subst b a) handle no_match => NONE)
35.553 + end
35.554 +
35.555 +fun apply_subst vars_allowed subst =
35.556 + let
35.557 + open AbstractMachine
35.558 + fun app (t as (Const c)) =
35.559 + (case Inttab.lookup subst c of
35.560 + NONE => t
35.561 + | SOME (SOME t) => Computed t
35.562 + | SOME NONE => if vars_allowed then t else raise Compute "apply_subst: no vars allowed")
35.563 + | app (t as (Var _)) = t
35.564 + | app (App (u, v)) = App (app u, app v)
35.565 + | app (Abs m) = Abs (app m)
35.566 + in
35.567 + app
35.568 + end
35.569 +
35.570 +fun splicein n l L = List.take (L, n) @ l @ List.drop (L, n+1)
35.571 +
35.572 +fun evaluate_prem computer prem_no th =
35.573 +let
35.574 + val _ = check_compatible computer th
35.575 + val prems = prems_of_theorem th
35.576 + val varsubst = varsubst_of_theorem th
35.577 + fun run vars_allowed t =
35.578 + runprog (prog_of computer) (apply_subst vars_allowed varsubst t)
35.579 +in
35.580 + case nth prems prem_no of
35.581 + Prem _ => raise Compute "evaluate_prem: no equality premise"
35.582 + | EqPrem (a, b, ty, _) =>
35.583 + let
35.584 + val a' = run false a
35.585 + val b' = run true b
35.586 + in
35.587 + case match_aterms varsubst b' a' of
35.588 + NONE =>
35.589 + let
35.590 + fun mk s = Syntax.string_of_term_global Pure.thy
35.591 + (infer_types (naming_of computer) (encoding_of computer) ty s)
35.592 + val left = "computed left side: "^(mk a')
35.593 + val right = "computed right side: "^(mk b')
35.594 + in
35.595 + raise Compute ("evaluate_prem: cannot assign computed left to right hand side\n"^left^"\n"^right^"\n")
35.596 + end
35.597 + | SOME varsubst =>
35.598 + update_prems (splicein prem_no [] prems) (update_varsubst varsubst th)
35.599 + end
35.600 +end
35.601 +
35.602 +fun prem2term (Prem t) = t
35.603 + | prem2term (EqPrem (a,b,_,eq)) =
35.604 + AbstractMachine.App (AbstractMachine.App (AbstractMachine.Const eq, a), b)
35.605 +
35.606 +fun modus_ponens computer prem_no th' th =
35.607 +let
35.608 + val _ = check_compatible computer th
35.609 + val thy =
35.610 + let
35.611 + val thy1 = theory_of_theorem th
35.612 + val thy2 = theory_of_thm th'
35.613 + in
35.614 + if Theory.subthy (thy1, thy2) then thy2
35.615 + else if Theory.subthy (thy2, thy1) then thy1 else
35.616 + raise Compute "modus_ponens: theorems are not compatible with each other"
35.617 + end
35.618 + val th' = make_theorem computer th' []
35.619 + val varsubst = varsubst_of_theorem th
35.620 + fun run vars_allowed t =
35.621 + runprog (prog_of computer) (apply_subst vars_allowed varsubst t)
35.622 + val prems = prems_of_theorem th
35.623 + val prem = run true (prem2term (nth prems prem_no))
35.624 + val concl = run false (concl_of_theorem th')
35.625 +in
35.626 + case match_aterms varsubst prem concl of
35.627 + NONE => raise Compute "modus_ponens: conclusion does not match premise"
35.628 + | SOME varsubst =>
35.629 + let
35.630 + val th = update_varsubst varsubst th
35.631 + val th = update_prems (splicein prem_no (prems_of_theorem th') prems) th
35.632 + val th = update_hyps (merge_hyps (hyps_of_theorem th) (hyps_of_theorem th')) th
35.633 + val th = update_shyps (merge_shyps (shyps_of_theorem th) (shyps_of_theorem th')) th
35.634 + in
35.635 + update_theory thy th
35.636 + end
35.637 +end
35.638 +
35.639 +fun simplify computer th =
35.640 +let
35.641 + val _ = check_compatible computer th
35.642 + val varsubst = varsubst_of_theorem th
35.643 + val encoding = encoding_of computer
35.644 + val naming = naming_of computer
35.645 + fun infer t = infer_types naming encoding @{typ "prop"} t
35.646 + fun run t = infer (runprog (prog_of computer) (apply_subst true varsubst t))
35.647 + fun runprem p = run (prem2term p)
35.648 + val prop = Logic.list_implies (map runprem (prems_of_theorem th), run (concl_of_theorem th))
35.649 + val hyps = merge_hyps (hyps_of computer) (hyps_of_theorem th)
35.650 + val shyps = merge_shyps (shyps_of_theorem th) (Sorttab.keys (shyptab_of computer))
35.651 +in
35.652 + export_thm (theory_of_theorem th) hyps shyps prop
35.653 +end
35.654 +
35.655 +end
35.656 +
36.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
36.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/linker.ML Sat Mar 17 12:52:40 2012 +0100
36.3 @@ -0,0 +1,470 @@
36.4 +(* Title: HOL/Matrix/Compute_Oracle/linker.ML
36.5 + Author: Steven Obua
36.6 +
36.7 +This module solves the problem that the computing oracle does not
36.8 +instantiate polymorphic rules. By going through the PCompute
36.9 +interface, all possible instantiations are resolved by compiling new
36.10 +programs, if necessary. The obvious disadvantage of this approach is
36.11 +that in the worst case for each new term to be rewritten, a new
36.12 +program may be compiled.
36.13 +*)
36.14 +
36.15 +(*
36.16 + Given constants/frees c_1::t_1, c_2::t_2, ...., c_n::t_n,
36.17 + and constants/frees d_1::d_1, d_2::s_2, ..., d_m::s_m
36.18 +
36.19 + Find all substitutions S such that
36.20 + a) the domain of S is tvars (t_1, ..., t_n)
36.21 + b) there are indices i_1, ..., i_k, and j_1, ..., j_k with
36.22 + 1. S (c_i_1::t_i_1) = d_j_1::s_j_1, ..., S (c_i_k::t_i_k) = d_j_k::s_j_k
36.23 + 2. tvars (t_i_1, ..., t_i_k) = tvars (t_1, ..., t_n)
36.24 +*)
36.25 +signature LINKER =
36.26 +sig
36.27 + exception Link of string
36.28 +
36.29 + datatype constant = Constant of bool * string * typ
36.30 + val constant_of : term -> constant
36.31 +
36.32 + type instances
36.33 + type subst = Type.tyenv
36.34 +
36.35 + val empty : constant list -> instances
36.36 + val typ_of_constant : constant -> typ
36.37 + val add_instances : theory -> instances -> constant list -> subst list * instances
36.38 + val substs_of : instances -> subst list
36.39 + val is_polymorphic : constant -> bool
36.40 + val distinct_constants : constant list -> constant list
36.41 + val collect_consts : term list -> constant list
36.42 +end
36.43 +
36.44 +structure Linker : LINKER = struct
36.45 +
36.46 +exception Link of string;
36.47 +
36.48 +type subst = Type.tyenv
36.49 +
36.50 +datatype constant = Constant of bool * string * typ
36.51 +fun constant_of (Const (name, ty)) = Constant (false, name, ty)
36.52 + | constant_of (Free (name, ty)) = Constant (true, name, ty)
36.53 + | constant_of _ = raise Link "constant_of"
36.54 +
36.55 +fun bool_ord (x,y) = if x then (if y then EQUAL else GREATER) else (if y then LESS else EQUAL)
36.56 +fun constant_ord (Constant (x1,x2,x3), Constant (y1,y2,y3)) = (prod_ord (prod_ord bool_ord fast_string_ord) Term_Ord.typ_ord) (((x1,x2),x3), ((y1,y2),y3))
36.57 +fun constant_modty_ord (Constant (x1,x2,_), Constant (y1,y2,_)) = (prod_ord bool_ord fast_string_ord) ((x1,x2), (y1,y2))
36.58 +
36.59 +
36.60 +structure Consttab = Table(type key = constant val ord = constant_ord);
36.61 +structure ConsttabModTy = Table(type key = constant val ord = constant_modty_ord);
36.62 +
36.63 +fun typ_of_constant (Constant (_, _, ty)) = ty
36.64 +
36.65 +val empty_subst = (Vartab.empty : Type.tyenv)
36.66 +
36.67 +fun merge_subst (A:Type.tyenv) (B:Type.tyenv) =
36.68 + SOME (Vartab.fold (fn (v, t) =>
36.69 + fn tab =>
36.70 + (case Vartab.lookup tab v of
36.71 + NONE => Vartab.update (v, t) tab
36.72 + | SOME t' => if t = t' then tab else raise Type.TYPE_MATCH)) A B)
36.73 + handle Type.TYPE_MATCH => NONE
36.74 +
36.75 +fun subst_ord (A:Type.tyenv, B:Type.tyenv) =
36.76 + (list_ord (prod_ord Term_Ord.fast_indexname_ord (prod_ord Term_Ord.sort_ord Term_Ord.typ_ord))) (Vartab.dest A, Vartab.dest B)
36.77 +
36.78 +structure Substtab = Table(type key = Type.tyenv val ord = subst_ord);
36.79 +
36.80 +fun substtab_union c = Substtab.fold Substtab.update c
36.81 +fun substtab_unions [] = Substtab.empty
36.82 + | substtab_unions [c] = c
36.83 + | substtab_unions (c::cs) = substtab_union c (substtab_unions cs)
36.84 +
36.85 +datatype instances = Instances of unit ConsttabModTy.table * Type.tyenv Consttab.table Consttab.table * constant list list * unit Substtab.table
36.86 +
36.87 +fun is_polymorphic (Constant (_, _, ty)) = not (null (Term.add_tvarsT ty []))
36.88 +
36.89 +fun distinct_constants cs =
36.90 + Consttab.keys (fold (fn c => Consttab.update (c, ())) cs Consttab.empty)
36.91 +
36.92 +fun empty cs =
36.93 + let
36.94 + val cs = distinct_constants (filter is_polymorphic cs)
36.95 + val old_cs = cs
36.96 +(* fun collect_tvars ty tab = fold (fn v => fn tab => Typtab.update (TVar v, ()) tab) (Misc_Legacy.typ_tvars ty) tab
36.97 + val tvars_count = length (Typtab.keys (fold (fn c => fn tab => collect_tvars (typ_of_constant c) tab) cs Typtab.empty))
36.98 + fun tvars_of ty = collect_tvars ty Typtab.empty
36.99 + val cs = map (fn c => (c, tvars_of (typ_of_constant c))) cs
36.100 +
36.101 + fun tyunion A B =
36.102 + Typtab.fold
36.103 + (fn (v,()) => fn tab => Typtab.update (v, case Typtab.lookup tab v of NONE => 1 | SOME n => n+1) tab)
36.104 + A B
36.105 +
36.106 + fun is_essential A B =
36.107 + Typtab.fold
36.108 + (fn (v, ()) => fn essential => essential orelse (case Typtab.lookup B v of NONE => raise Link "is_essential" | SOME n => n=1))
36.109 + A false
36.110 +
36.111 + fun add_minimal (c', tvs') (tvs, cs) =
36.112 + let
36.113 + val tvs = tyunion tvs' tvs
36.114 + val cs = (c', tvs')::cs
36.115 + in
36.116 + if forall (fn (c',tvs') => is_essential tvs' tvs) cs then
36.117 + SOME (tvs, cs)
36.118 + else
36.119 + NONE
36.120 + end
36.121 +
36.122 + fun is_spanning (tvs, _) = (length (Typtab.keys tvs) = tvars_count)
36.123 +
36.124 + fun generate_minimal_subsets subsets [] = subsets
36.125 + | generate_minimal_subsets subsets (c::cs) =
36.126 + let
36.127 + val subsets' = map_filter (add_minimal c) subsets
36.128 + in
36.129 + generate_minimal_subsets (subsets@subsets') cs
36.130 + end*)
36.131 +
36.132 + val minimal_subsets = [old_cs] (*map (fn (tvs, cs) => map fst cs) (filter is_spanning (generate_minimal_subsets [(Typtab.empty, [])] cs))*)
36.133 +
36.134 + val constants = Consttab.keys (fold (fold (fn c => Consttab.update (c, ()))) minimal_subsets Consttab.empty)
36.135 +
36.136 + in
36.137 + Instances (
36.138 + fold (fn c => fn tab => ConsttabModTy.update (c, ()) tab) constants ConsttabModTy.empty,
36.139 + Consttab.make (map (fn c => (c, Consttab.empty : Type.tyenv Consttab.table)) constants),
36.140 + minimal_subsets, Substtab.empty)
36.141 + end
36.142 +
36.143 +local
36.144 +fun calc ctab substtab [] = substtab
36.145 + | calc ctab substtab (c::cs) =
36.146 + let
36.147 + val csubsts = map snd (Consttab.dest (the (Consttab.lookup ctab c)))
36.148 + fun merge_substs substtab subst =
36.149 + Substtab.fold (fn (s,_) =>
36.150 + fn tab =>
36.151 + (case merge_subst subst s of NONE => tab | SOME s => Substtab.update (s, ()) tab))
36.152 + substtab Substtab.empty
36.153 + val substtab = substtab_unions (map (merge_substs substtab) csubsts)
36.154 + in
36.155 + calc ctab substtab cs
36.156 + end
36.157 +in
36.158 +fun calc_substs ctab (cs:constant list) = calc ctab (Substtab.update (empty_subst, ()) Substtab.empty) cs
36.159 +end
36.160 +
36.161 +fun add_instances thy (Instances (cfilter, ctab,minsets,substs)) cs =
36.162 + let
36.163 +(* val _ = writeln (makestring ("add_instances: ", length_cs, length cs, length (Consttab.keys ctab)))*)
36.164 + fun calc_instantiations (constant as Constant (free, name, ty)) instantiations =
36.165 + Consttab.fold (fn (constant' as Constant (free', name', ty'), insttab) =>
36.166 + fn instantiations =>
36.167 + if free <> free' orelse name <> name' then
36.168 + instantiations
36.169 + else case Consttab.lookup insttab constant of
36.170 + SOME _ => instantiations
36.171 + | NONE => ((constant', (constant, Sign.typ_match thy (ty', ty) empty_subst))::instantiations
36.172 + handle Type.TYPE_MATCH => instantiations))
36.173 + ctab instantiations
36.174 + val instantiations = fold calc_instantiations cs []
36.175 + (*val _ = writeln ("instantiations = "^(makestring (length instantiations)))*)
36.176 + fun update_ctab (constant', entry) ctab =
36.177 + (case Consttab.lookup ctab constant' of
36.178 + NONE => raise Link "internal error: update_ctab"
36.179 + | SOME tab => Consttab.update (constant', Consttab.update entry tab) ctab)
36.180 + val ctab = fold update_ctab instantiations ctab
36.181 + val new_substs = fold (fn minset => fn substs => substtab_union (calc_substs ctab minset) substs)
36.182 + minsets Substtab.empty
36.183 + val (added_substs, substs) =
36.184 + Substtab.fold (fn (ns, _) =>
36.185 + fn (added, substtab) =>
36.186 + (case Substtab.lookup substs ns of
36.187 + NONE => (ns::added, Substtab.update (ns, ()) substtab)
36.188 + | SOME () => (added, substtab)))
36.189 + new_substs ([], substs)
36.190 + in
36.191 + (added_substs, Instances (cfilter, ctab, minsets, substs))
36.192 + end
36.193 +
36.194 +fun substs_of (Instances (_,_,_,substs)) = Substtab.keys substs
36.195 +
36.196 +
36.197 +local
36.198 +
36.199 +fun collect (Var _) tab = tab
36.200 + | collect (Bound _) tab = tab
36.201 + | collect (a $ b) tab = collect b (collect a tab)
36.202 + | collect (Abs (_, _, body)) tab = collect body tab
36.203 + | collect t tab = Consttab.update (constant_of t, ()) tab
36.204 +
36.205 +in
36.206 + fun collect_consts tms = Consttab.keys (fold collect tms Consttab.empty)
36.207 +end
36.208 +
36.209 +end
36.210 +
36.211 +signature PCOMPUTE =
36.212 +sig
36.213 + type pcomputer
36.214 +
36.215 + val make : Compute.machine -> theory -> thm list -> Linker.constant list -> pcomputer
36.216 + val make_with_cache : Compute.machine -> theory -> term list -> thm list -> Linker.constant list -> pcomputer
36.217 +
36.218 + val add_instances : pcomputer -> Linker.constant list -> bool
36.219 + val add_instances' : pcomputer -> term list -> bool
36.220 +
36.221 + val rewrite : pcomputer -> cterm list -> thm list
36.222 + val simplify : pcomputer -> Compute.theorem -> thm
36.223 +
36.224 + val make_theorem : pcomputer -> thm -> string list -> Compute.theorem
36.225 + val instantiate : pcomputer -> (string * cterm) list -> Compute.theorem -> Compute.theorem
36.226 + val evaluate_prem : pcomputer -> int -> Compute.theorem -> Compute.theorem
36.227 + val modus_ponens : pcomputer -> int -> thm -> Compute.theorem -> Compute.theorem
36.228 +
36.229 +end
36.230 +
36.231 +structure PCompute : PCOMPUTE = struct
36.232 +
36.233 +exception PCompute of string
36.234 +
36.235 +datatype theorem = MonoThm of thm | PolyThm of thm * Linker.instances * thm list
36.236 +datatype pattern = MonoPattern of term | PolyPattern of term * Linker.instances * term list
36.237 +
36.238 +datatype pcomputer =
36.239 + PComputer of theory_ref * Compute.computer * theorem list Unsynchronized.ref *
36.240 + pattern list Unsynchronized.ref
36.241 +
36.242 +(*fun collect_consts (Var x) = []
36.243 + | collect_consts (Bound _) = []
36.244 + | collect_consts (a $ b) = (collect_consts a)@(collect_consts b)
36.245 + | collect_consts (Abs (_, _, body)) = collect_consts body
36.246 + | collect_consts t = [Linker.constant_of t]*)
36.247 +
36.248 +fun computer_of (PComputer (_,computer,_,_)) = computer
36.249 +
36.250 +fun collect_consts_of_thm th =
36.251 + let
36.252 + val th = prop_of th
36.253 + val (prems, th) = (Logic.strip_imp_prems th, Logic.strip_imp_concl th)
36.254 + val (left, right) = Logic.dest_equals th
36.255 + in
36.256 + (Linker.collect_consts [left], Linker.collect_consts (right::prems))
36.257 + end
36.258 +
36.259 +fun create_theorem th =
36.260 +let
36.261 + val (left, right) = collect_consts_of_thm th
36.262 + val polycs = filter Linker.is_polymorphic left
36.263 + val tytab = fold (fn p => fn tab => fold (fn n => fn tab => Typtab.update (TVar n, ()) tab) (Misc_Legacy.typ_tvars (Linker.typ_of_constant p)) tab) polycs Typtab.empty
36.264 + fun check_const (c::cs) cs' =
36.265 + let
36.266 + val tvars = Misc_Legacy.typ_tvars (Linker.typ_of_constant c)
36.267 + val wrong = fold (fn n => fn wrong => wrong orelse is_none (Typtab.lookup tytab (TVar n))) tvars false
36.268 + in
36.269 + if wrong then raise PCompute "right hand side of theorem contains type variables which do not occur on the left hand side"
36.270 + else
36.271 + if null (tvars) then
36.272 + check_const cs (c::cs')
36.273 + else
36.274 + check_const cs cs'
36.275 + end
36.276 + | check_const [] cs' = cs'
36.277 + val monocs = check_const right []
36.278 +in
36.279 + if null (polycs) then
36.280 + (monocs, MonoThm th)
36.281 + else
36.282 + (monocs, PolyThm (th, Linker.empty polycs, []))
36.283 +end
36.284 +
36.285 +fun create_pattern pat =
36.286 +let
36.287 + val cs = Linker.collect_consts [pat]
36.288 + val polycs = filter Linker.is_polymorphic cs
36.289 +in
36.290 + if null (polycs) then
36.291 + MonoPattern pat
36.292 + else
36.293 + PolyPattern (pat, Linker.empty polycs, [])
36.294 +end
36.295 +
36.296 +fun create_computer machine thy pats ths =
36.297 + let
36.298 + fun add (MonoThm th) ths = th::ths
36.299 + | add (PolyThm (_, _, ths')) ths = ths'@ths
36.300 + fun addpat (MonoPattern p) pats = p::pats
36.301 + | addpat (PolyPattern (_, _, ps)) pats = ps@pats
36.302 + val ths = fold_rev add ths []
36.303 + val pats = fold_rev addpat pats []
36.304 + in
36.305 + Compute.make_with_cache machine thy pats ths
36.306 + end
36.307 +
36.308 +fun update_computer computer pats ths =
36.309 + let
36.310 + fun add (MonoThm th) ths = th::ths
36.311 + | add (PolyThm (_, _, ths')) ths = ths'@ths
36.312 + fun addpat (MonoPattern p) pats = p::pats
36.313 + | addpat (PolyPattern (_, _, ps)) pats = ps@pats
36.314 + val ths = fold_rev add ths []
36.315 + val pats = fold_rev addpat pats []
36.316 + in
36.317 + Compute.update_with_cache computer pats ths
36.318 + end
36.319 +
36.320 +fun conv_subst thy (subst : Type.tyenv) =
36.321 + map (fn (iname, (sort, ty)) => (ctyp_of thy (TVar (iname, sort)), ctyp_of thy ty)) (Vartab.dest subst)
36.322 +
36.323 +fun add_monos thy monocs pats ths =
36.324 + let
36.325 + val changed = Unsynchronized.ref false
36.326 + fun add monocs (th as (MonoThm _)) = ([], th)
36.327 + | add monocs (PolyThm (th, instances, instanceths)) =
36.328 + let
36.329 + val (newsubsts, instances) = Linker.add_instances thy instances monocs
36.330 + val _ = if not (null newsubsts) then changed := true else ()
36.331 + val newths = map (fn subst => Thm.instantiate (conv_subst thy subst, []) th) newsubsts
36.332 +(* val _ = if not (null newths) then (print ("added new theorems: ", newths); ()) else ()*)
36.333 + val newmonos = fold (fn th => fn monos => (snd (collect_consts_of_thm th))@monos) newths []
36.334 + in
36.335 + (newmonos, PolyThm (th, instances, instanceths@newths))
36.336 + end
36.337 + fun addpats monocs (pat as (MonoPattern _)) = pat
36.338 + | addpats monocs (PolyPattern (p, instances, instancepats)) =
36.339 + let
36.340 + val (newsubsts, instances) = Linker.add_instances thy instances monocs
36.341 + val _ = if not (null newsubsts) then changed := true else ()
36.342 + val newpats = map (fn subst => Envir.subst_term_types subst p) newsubsts
36.343 + in
36.344 + PolyPattern (p, instances, instancepats@newpats)
36.345 + end
36.346 + fun step monocs ths =
36.347 + fold_rev (fn th =>
36.348 + fn (newmonos, ths) =>
36.349 + let
36.350 + val (newmonos', th') = add monocs th
36.351 + in
36.352 + (newmonos'@newmonos, th'::ths)
36.353 + end)
36.354 + ths ([], [])
36.355 + fun loop monocs pats ths =
36.356 + let
36.357 + val (monocs', ths') = step monocs ths
36.358 + val pats' = map (addpats monocs) pats
36.359 + in
36.360 + if null (monocs') then
36.361 + (pats', ths')
36.362 + else
36.363 + loop monocs' pats' ths'
36.364 + end
36.365 + val result = loop monocs pats ths
36.366 + in
36.367 + (!changed, result)
36.368 + end
36.369 +
36.370 +datatype cthm = ComputeThm of term list * sort list * term
36.371 +
36.372 +fun thm2cthm th =
36.373 + let
36.374 + val {hyps, prop, shyps, ...} = Thm.rep_thm th
36.375 + in
36.376 + ComputeThm (hyps, shyps, prop)
36.377 + end
36.378 +
36.379 +val cthm_ord' = prod_ord (prod_ord (list_ord Term_Ord.term_ord) (list_ord Term_Ord.sort_ord)) Term_Ord.term_ord
36.380 +
36.381 +fun cthm_ord (ComputeThm (h1, sh1, p1), ComputeThm (h2, sh2, p2)) = cthm_ord' (((h1,sh1), p1), ((h2, sh2), p2))
36.382 +
36.383 +structure CThmtab = Table(type key = cthm val ord = cthm_ord)
36.384 +
36.385 +fun remove_duplicates ths =
36.386 + let
36.387 + val counter = Unsynchronized.ref 0
36.388 + val tab = Unsynchronized.ref (CThmtab.empty : unit CThmtab.table)
36.389 + val thstab = Unsynchronized.ref (Inttab.empty : thm Inttab.table)
36.390 + fun update th =
36.391 + let
36.392 + val key = thm2cthm th
36.393 + in
36.394 + case CThmtab.lookup (!tab) key of
36.395 + NONE => ((tab := CThmtab.update_new (key, ()) (!tab)); thstab := Inttab.update_new (!counter, th) (!thstab); counter := !counter + 1)
36.396 + | _ => ()
36.397 + end
36.398 + val _ = map update ths
36.399 + in
36.400 + map snd (Inttab.dest (!thstab))
36.401 + end
36.402 +
36.403 +fun make_with_cache machine thy pats ths cs =
36.404 + let
36.405 + val ths = remove_duplicates ths
36.406 + val (monocs, ths) = fold_rev (fn th =>
36.407 + fn (monocs, ths) =>
36.408 + let val (m, t) = create_theorem th in
36.409 + (m@monocs, t::ths)
36.410 + end)
36.411 + ths (cs, [])
36.412 + val pats = map create_pattern pats
36.413 + val (_, (pats, ths)) = add_monos thy monocs pats ths
36.414 + val computer = create_computer machine thy pats ths
36.415 + in
36.416 + PComputer (Theory.check_thy thy, computer, Unsynchronized.ref ths, Unsynchronized.ref pats)
36.417 + end
36.418 +
36.419 +fun make machine thy ths cs = make_with_cache machine thy [] ths cs
36.420 +
36.421 +fun add_instances (PComputer (thyref, computer, rths, rpats)) cs =
36.422 + let
36.423 + val thy = Theory.deref thyref
36.424 + val (changed, (pats, ths)) = add_monos thy cs (!rpats) (!rths)
36.425 + in
36.426 + if changed then
36.427 + (update_computer computer pats ths;
36.428 + rths := ths;
36.429 + rpats := pats;
36.430 + true)
36.431 + else
36.432 + false
36.433 +
36.434 + end
36.435 +
36.436 +fun add_instances' pc ts = add_instances pc (Linker.collect_consts ts)
36.437 +
36.438 +fun rewrite pc cts =
36.439 + let
36.440 + val _ = add_instances' pc (map term_of cts)
36.441 + val computer = (computer_of pc)
36.442 + in
36.443 + map (fn ct => Compute.rewrite computer ct) cts
36.444 + end
36.445 +
36.446 +fun simplify pc th = Compute.simplify (computer_of pc) th
36.447 +
36.448 +fun make_theorem pc th vars =
36.449 + let
36.450 + val _ = add_instances' pc [prop_of th]
36.451 +
36.452 + in
36.453 + Compute.make_theorem (computer_of pc) th vars
36.454 + end
36.455 +
36.456 +fun instantiate pc insts th =
36.457 + let
36.458 + val _ = add_instances' pc (map (term_of o snd) insts)
36.459 + in
36.460 + Compute.instantiate (computer_of pc) insts th
36.461 + end
36.462 +
36.463 +fun evaluate_prem pc prem_no th = Compute.evaluate_prem (computer_of pc) prem_no th
36.464 +
36.465 +fun modus_ponens pc prem_no th' th =
36.466 + let
36.467 + val _ = add_instances' pc [prop_of th']
36.468 + in
36.469 + Compute.modus_ponens (computer_of pc) prem_no th' th
36.470 + end
36.471 +
36.472 +
36.473 +end
37.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
37.2 +++ b/src/HOL/Matrix_LP/Compute_Oracle/report.ML Sat Mar 17 12:52:40 2012 +0100
37.3 @@ -0,0 +1,33 @@
37.4 +structure Report =
37.5 +struct
37.6 +
37.7 +local
37.8 +
37.9 + val report_depth = Unsynchronized.ref 0
37.10 + fun space n = if n <= 0 then "" else (space (n-1))^" "
37.11 + fun report_space () = space (!report_depth)
37.12 +
37.13 +in
37.14 +
37.15 +fun timeit f =
37.16 + let
37.17 + val t1 = Timing.start ()
37.18 + val x = f ()
37.19 + val t2 = Timing.message (Timing.result t1)
37.20 + val _ = writeln ((report_space ()) ^ "--> "^t2)
37.21 + in
37.22 + x
37.23 + end
37.24 +
37.25 +fun report s f =
37.26 +let
37.27 + val _ = writeln ((report_space ())^s)
37.28 + val _ = report_depth := !report_depth + 1
37.29 + val x = timeit f
37.30 + val _ = report_depth := !report_depth - 1
37.31 +in
37.32 + x
37.33 +end
37.34 +
37.35 +end
37.36 +end
37.37 \ No newline at end of file
38.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
38.2 +++ b/src/HOL/Matrix_LP/Cplex.thy Sat Mar 17 12:52:40 2012 +0100
38.3 @@ -0,0 +1,67 @@
38.4 +(* Title: HOL/Matrix/Cplex.thy
38.5 + Author: Steven Obua
38.6 +*)
38.7 +
38.8 +theory Cplex
38.9 +imports SparseMatrix LP ComputeFloat ComputeNumeral
38.10 +uses "Cplex_tools.ML" "CplexMatrixConverter.ML" "FloatSparseMatrixBuilder.ML"
38.11 + "fspmlp.ML" ("matrixlp.ML")
38.12 +begin
38.13 +
38.14 +lemma spm_mult_le_dual_prts:
38.15 + assumes
38.16 + "sorted_sparse_matrix A1"
38.17 + "sorted_sparse_matrix A2"
38.18 + "sorted_sparse_matrix c1"
38.19 + "sorted_sparse_matrix c2"
38.20 + "sorted_sparse_matrix y"
38.21 + "sorted_sparse_matrix r1"
38.22 + "sorted_sparse_matrix r2"
38.23 + "sorted_spvec b"
38.24 + "le_spmat [] y"
38.25 + "sparse_row_matrix A1 \<le> A"
38.26 + "A \<le> sparse_row_matrix A2"
38.27 + "sparse_row_matrix c1 \<le> c"
38.28 + "c \<le> sparse_row_matrix c2"
38.29 + "sparse_row_matrix r1 \<le> x"
38.30 + "x \<le> sparse_row_matrix r2"
38.31 + "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
38.32 + shows
38.33 + "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
38.34 + (let s1 = diff_spmat c1 (mult_spmat y A2); s2 = diff_spmat c2 (mult_spmat y A1) in
38.35 + add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
38.36 + (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))))"
38.37 + apply (simp add: Let_def)
38.38 + apply (insert assms)
38.39 + apply (simp add: sparse_row_matrix_op_simps algebra_simps)
38.40 + apply (rule mult_le_dual_prts[where A=A, simplified Let_def algebra_simps])
38.41 + apply (auto)
38.42 + done
38.43 +
38.44 +lemma spm_mult_le_dual_prts_no_let:
38.45 + assumes
38.46 + "sorted_sparse_matrix A1"
38.47 + "sorted_sparse_matrix A2"
38.48 + "sorted_sparse_matrix c1"
38.49 + "sorted_sparse_matrix c2"
38.50 + "sorted_sparse_matrix y"
38.51 + "sorted_sparse_matrix r1"
38.52 + "sorted_sparse_matrix r2"
38.53 + "sorted_spvec b"
38.54 + "le_spmat [] y"
38.55 + "sparse_row_matrix A1 \<le> A"
38.56 + "A \<le> sparse_row_matrix A2"
38.57 + "sparse_row_matrix c1 \<le> c"
38.58 + "c \<le> sparse_row_matrix c2"
38.59 + "sparse_row_matrix r1 \<le> x"
38.60 + "x \<le> sparse_row_matrix r2"
38.61 + "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
38.62 + shows
38.63 + "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
38.64 + (mult_est_spmat r1 r2 (diff_spmat c1 (mult_spmat y A2)) (diff_spmat c2 (mult_spmat y A1))))"
38.65 + by (simp add: assms mult_est_spmat_def spm_mult_le_dual_prts[where A=A, simplified Let_def])
38.66 +
38.67 +use "matrixlp.ML"
38.68 +
38.69 +end
38.70 +
39.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
39.2 +++ b/src/HOL/Matrix_LP/CplexMatrixConverter.ML Sat Mar 17 12:52:40 2012 +0100
39.3 @@ -0,0 +1,128 @@
39.4 +(* Title: HOL/Matrix/CplexMatrixConverter.ML
39.5 + Author: Steven Obua
39.6 +*)
39.7 +
39.8 +signature MATRIX_BUILDER =
39.9 +sig
39.10 + type vector
39.11 + type matrix
39.12 +
39.13 + val empty_vector : vector
39.14 + val empty_matrix : matrix
39.15 +
39.16 + exception Nat_expected of int
39.17 + val set_elem : vector -> int -> string -> vector
39.18 + val set_vector : matrix -> int -> vector -> matrix
39.19 +end;
39.20 +
39.21 +signature CPLEX_MATRIX_CONVERTER =
39.22 +sig
39.23 + structure cplex : CPLEX
39.24 + structure matrix_builder : MATRIX_BUILDER
39.25 + type vector = matrix_builder.vector
39.26 + type matrix = matrix_builder.matrix
39.27 + type naming = int * (int -> string) * (string -> int)
39.28 +
39.29 + exception Converter of string
39.30 +
39.31 + (* program must fulfill is_normed_cplexProg and must be an element of the image of elim_nonfree_bounds *)
39.32 + (* convert_prog maximize c A b naming *)
39.33 + val convert_prog : cplex.cplexProg -> bool * vector * matrix * vector * naming
39.34 +
39.35 + (* results must be optimal, converts_results returns the optimal value as string and the solution as vector *)
39.36 + (* convert_results results name2index *)
39.37 + val convert_results : cplex.cplexResult -> (string -> int) -> string * vector
39.38 +end;
39.39 +
39.40 +functor MAKE_CPLEX_MATRIX_CONVERTER (structure cplex: CPLEX and matrix_builder: MATRIX_BUILDER) : CPLEX_MATRIX_CONVERTER =
39.41 +struct
39.42 +
39.43 +structure cplex = cplex
39.44 +structure matrix_builder = matrix_builder
39.45 +type matrix = matrix_builder.matrix
39.46 +type vector = matrix_builder.vector
39.47 +type naming = int * (int -> string) * (string -> int)
39.48 +
39.49 +open matrix_builder
39.50 +open cplex
39.51 +
39.52 +exception Converter of string;
39.53 +
39.54 +fun neg_term (cplexNeg t) = t
39.55 + | neg_term (cplexSum ts) = cplexSum (map neg_term ts)
39.56 + | neg_term t = cplexNeg t
39.57 +
39.58 +fun convert_prog (cplexProg (_, goal, constrs, bounds)) =
39.59 + let
39.60 + fun build_naming index i2s s2i [] = (index, i2s, s2i)
39.61 + | build_naming index i2s s2i (cplexBounds (cplexNeg cplexInf, cplexLeq, cplexVar v, cplexLeq, cplexInf)::bounds)
39.62 + = build_naming (index+1) (Inttab.update (index, v) i2s) (Symtab.update_new (v, index) s2i) bounds
39.63 + | build_naming _ _ _ _ = raise (Converter "nonfree bound")
39.64 +
39.65 + val (varcount, i2s_tab, s2i_tab) = build_naming 0 Inttab.empty Symtab.empty bounds
39.66 +
39.67 + fun i2s i = case Inttab.lookup i2s_tab i of NONE => raise (Converter "index not found")
39.68 + | SOME n => n
39.69 + fun s2i s = case Symtab.lookup s2i_tab s of NONE => raise (Converter ("name not found: "^s))
39.70 + | SOME i => i
39.71 + fun num2str positive (cplexNeg t) = num2str (not positive) t
39.72 + | num2str positive (cplexNum num) = if positive then num else "-"^num
39.73 + | num2str _ _ = raise (Converter "term is not a (possibly signed) number")
39.74 +
39.75 + fun setprod vec positive (cplexNeg t) = setprod vec (not positive) t
39.76 + | setprod vec positive (cplexVar v) = set_elem vec (s2i v) (if positive then "1" else "-1")
39.77 + | setprod vec positive (cplexProd (cplexNum num, cplexVar v)) =
39.78 + set_elem vec (s2i v) (if positive then num else "-"^num)
39.79 + | setprod _ _ _ = raise (Converter "term is not a normed product")
39.80 +
39.81 + fun sum2vec (cplexSum ts) = fold (fn t => fn vec => setprod vec true t) ts empty_vector
39.82 + | sum2vec t = setprod empty_vector true t
39.83 +
39.84 + fun constrs2Ab j A b [] = (A, b)
39.85 + | constrs2Ab j A b ((_, cplexConstr (cplexLeq, (t1,t2)))::cs) =
39.86 + constrs2Ab (j+1) (set_vector A j (sum2vec t1)) (set_elem b j (num2str true t2)) cs
39.87 + | constrs2Ab j A b ((_, cplexConstr (cplexGeq, (t1,t2)))::cs) =
39.88 + constrs2Ab (j+1) (set_vector A j (sum2vec (neg_term t1))) (set_elem b j (num2str true (neg_term t2))) cs
39.89 + | constrs2Ab j A b ((_, cplexConstr (cplexEq, (t1,t2)))::cs) =
39.90 + constrs2Ab j A b ((NONE, cplexConstr (cplexLeq, (t1,t2)))::
39.91 + (NONE, cplexConstr (cplexGeq, (t1, t2)))::cs)
39.92 + | constrs2Ab _ _ _ _ = raise (Converter "no strict constraints allowed")
39.93 +
39.94 + val (A, b) = constrs2Ab 0 empty_matrix empty_vector constrs
39.95 +
39.96 + val (goal_maximize, goal_term) =
39.97 + case goal of
39.98 + (cplexMaximize t) => (true, t)
39.99 + | (cplexMinimize t) => (false, t)
39.100 + in
39.101 + (goal_maximize, sum2vec goal_term, A, b, (varcount, i2s, s2i))
39.102 + end
39.103 +
39.104 +fun convert_results (cplex.Optimal (opt, entries)) name2index =
39.105 + let
39.106 + fun setv (name, value) v = matrix_builder.set_elem v (name2index name) value
39.107 + in
39.108 + (opt, fold setv entries (matrix_builder.empty_vector))
39.109 + end
39.110 + | convert_results _ _ = raise (Converter "No optimal result")
39.111 +
39.112 +end;
39.113 +
39.114 +structure SimpleMatrixBuilder : MATRIX_BUILDER =
39.115 +struct
39.116 +type vector = (int * string) list
39.117 +type matrix = (int * vector) list
39.118 +
39.119 +val empty_matrix = []
39.120 +val empty_vector = []
39.121 +
39.122 +exception Nat_expected of int;
39.123 +
39.124 +fun set_elem v i s = v @ [(i, s)]
39.125 +
39.126 +fun set_vector m i v = m @ [(i, v)]
39.127 +
39.128 +end;
39.129 +
39.130 +structure SimpleCplexMatrixConverter =
39.131 + MAKE_CPLEX_MATRIX_CONVERTER(structure cplex = Cplex and matrix_builder = SimpleMatrixBuilder);
40.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
40.2 +++ b/src/HOL/Matrix_LP/Cplex_tools.ML Sat Mar 17 12:52:40 2012 +0100
40.3 @@ -0,0 +1,1192 @@
40.4 +(* Title: HOL/Matrix/Cplex_tools.ML
40.5 + Author: Steven Obua
40.6 +*)
40.7 +
40.8 +signature CPLEX =
40.9 +sig
40.10 +
40.11 + datatype cplexTerm = cplexVar of string | cplexNum of string | cplexInf
40.12 + | cplexNeg of cplexTerm
40.13 + | cplexProd of cplexTerm * cplexTerm
40.14 + | cplexSum of (cplexTerm list)
40.15 +
40.16 + datatype cplexComp = cplexLe | cplexLeq | cplexEq | cplexGe | cplexGeq
40.17 +
40.18 + datatype cplexGoal = cplexMinimize of cplexTerm
40.19 + | cplexMaximize of cplexTerm
40.20 +
40.21 + datatype cplexConstr = cplexConstr of cplexComp *
40.22 + (cplexTerm * cplexTerm)
40.23 +
40.24 + datatype cplexBounds = cplexBounds of cplexTerm * cplexComp * cplexTerm
40.25 + * cplexComp * cplexTerm
40.26 + | cplexBound of cplexTerm * cplexComp * cplexTerm
40.27 +
40.28 + datatype cplexProg = cplexProg of string
40.29 + * cplexGoal
40.30 + * ((string option * cplexConstr)
40.31 + list)
40.32 + * cplexBounds list
40.33 +
40.34 + datatype cplexResult = Unbounded
40.35 + | Infeasible
40.36 + | Undefined
40.37 + | Optimal of string *
40.38 + (((* name *) string *
40.39 + (* value *) string) list)
40.40 +
40.41 + datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK
40.42 +
40.43 + exception Load_cplexFile of string
40.44 + exception Load_cplexResult of string
40.45 + exception Save_cplexFile of string
40.46 + exception Execute of string
40.47 +
40.48 + val load_cplexFile : string -> cplexProg
40.49 +
40.50 + val save_cplexFile : string -> cplexProg -> unit
40.51 +
40.52 + val elim_nonfree_bounds : cplexProg -> cplexProg
40.53 +
40.54 + val relax_strict_ineqs : cplexProg -> cplexProg
40.55 +
40.56 + val is_normed_cplexProg : cplexProg -> bool
40.57 +
40.58 + val get_solver : unit -> cplexSolver
40.59 + val set_solver : cplexSolver -> unit
40.60 + val solve : cplexProg -> cplexResult
40.61 +end;
40.62 +
40.63 +structure Cplex : CPLEX =
40.64 +struct
40.65 +
40.66 +datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK
40.67 +
40.68 +val cplexsolver = Unsynchronized.ref SOLVER_DEFAULT;
40.69 +fun get_solver () = !cplexsolver;
40.70 +fun set_solver s = (cplexsolver := s);
40.71 +
40.72 +exception Load_cplexFile of string;
40.73 +exception Load_cplexResult of string;
40.74 +exception Save_cplexFile of string;
40.75 +
40.76 +datatype cplexTerm = cplexVar of string
40.77 + | cplexNum of string
40.78 + | cplexInf
40.79 + | cplexNeg of cplexTerm
40.80 + | cplexProd of cplexTerm * cplexTerm
40.81 + | cplexSum of (cplexTerm list)
40.82 +datatype cplexComp = cplexLe | cplexLeq | cplexEq | cplexGe | cplexGeq
40.83 +datatype cplexGoal = cplexMinimize of cplexTerm | cplexMaximize of cplexTerm
40.84 +datatype cplexConstr = cplexConstr of cplexComp * (cplexTerm * cplexTerm)
40.85 +datatype cplexBounds = cplexBounds of cplexTerm * cplexComp * cplexTerm
40.86 + * cplexComp * cplexTerm
40.87 + | cplexBound of cplexTerm * cplexComp * cplexTerm
40.88 +datatype cplexProg = cplexProg of string
40.89 + * cplexGoal
40.90 + * ((string option * cplexConstr) list)
40.91 + * cplexBounds list
40.92 +
40.93 +fun rev_cmp cplexLe = cplexGe
40.94 + | rev_cmp cplexLeq = cplexGeq
40.95 + | rev_cmp cplexGe = cplexLe
40.96 + | rev_cmp cplexGeq = cplexLeq
40.97 + | rev_cmp cplexEq = cplexEq
40.98 +
40.99 +fun the NONE = raise (Load_cplexFile "SOME expected")
40.100 + | the (SOME x) = x;
40.101 +
40.102 +fun modulo_signed is_something (cplexNeg u) = is_something u
40.103 + | modulo_signed is_something u = is_something u
40.104 +
40.105 +fun is_Num (cplexNum _) = true
40.106 + | is_Num _ = false
40.107 +
40.108 +fun is_Inf cplexInf = true
40.109 + | is_Inf _ = false
40.110 +
40.111 +fun is_Var (cplexVar _) = true
40.112 + | is_Var _ = false
40.113 +
40.114 +fun is_Neg (cplexNeg _) = true
40.115 + | is_Neg _ = false
40.116 +
40.117 +fun is_normed_Prod (cplexProd (t1, t2)) =
40.118 + (is_Num t1) andalso (is_Var t2)
40.119 + | is_normed_Prod x = is_Var x
40.120 +
40.121 +fun is_normed_Sum (cplexSum ts) =
40.122 + (ts <> []) andalso forall (modulo_signed is_normed_Prod) ts
40.123 + | is_normed_Sum x = modulo_signed is_normed_Prod x
40.124 +
40.125 +fun is_normed_Constr (cplexConstr (_, (t1, t2))) =
40.126 + (is_normed_Sum t1) andalso (modulo_signed is_Num t2)
40.127 +
40.128 +fun is_Num_or_Inf x = is_Inf x orelse is_Num x
40.129 +
40.130 +fun is_normed_Bounds (cplexBounds (t1, c1, t2, c2, t3)) =
40.131 + (c1 = cplexLe orelse c1 = cplexLeq) andalso
40.132 + (c2 = cplexLe orelse c2 = cplexLeq) andalso
40.133 + is_Var t2 andalso
40.134 + modulo_signed is_Num_or_Inf t1 andalso
40.135 + modulo_signed is_Num_or_Inf t3
40.136 + | is_normed_Bounds (cplexBound (t1, c, t2)) =
40.137 + (is_Var t1 andalso (modulo_signed is_Num_or_Inf t2))
40.138 + orelse
40.139 + (c <> cplexEq andalso
40.140 + is_Var t2 andalso (modulo_signed is_Num_or_Inf t1))
40.141 +
40.142 +fun term_of_goal (cplexMinimize x) = x
40.143 + | term_of_goal (cplexMaximize x) = x
40.144 +
40.145 +fun is_normed_cplexProg (cplexProg (_, goal, constraints, bounds)) =
40.146 + is_normed_Sum (term_of_goal goal) andalso
40.147 + forall (fn (_,x) => is_normed_Constr x) constraints andalso
40.148 + forall is_normed_Bounds bounds
40.149 +
40.150 +fun is_NL s = s = "\n"
40.151 +
40.152 +fun is_blank s = forall (fn c => c <> #"\n" andalso Char.isSpace c) (String.explode s)
40.153 +
40.154 +fun is_num a =
40.155 + let
40.156 + val b = String.explode a
40.157 + fun num4 cs = forall Char.isDigit cs
40.158 + fun num3 [] = true
40.159 + | num3 (ds as (c::cs)) =
40.160 + if c = #"+" orelse c = #"-" then
40.161 + num4 cs
40.162 + else
40.163 + num4 ds
40.164 + fun num2 [] = true
40.165 + | num2 (c::cs) =
40.166 + if c = #"e" orelse c = #"E" then num3 cs
40.167 + else (Char.isDigit c) andalso num2 cs
40.168 + fun num1 [] = true
40.169 + | num1 (c::cs) =
40.170 + if c = #"." then num2 cs
40.171 + else if c = #"e" orelse c = #"E" then num3 cs
40.172 + else (Char.isDigit c) andalso num1 cs
40.173 + fun num [] = true
40.174 + | num (c::cs) =
40.175 + if c = #"." then num2 cs
40.176 + else (Char.isDigit c) andalso num1 cs
40.177 + in
40.178 + num b
40.179 + end
40.180 +
40.181 +fun is_delimiter s = s = "+" orelse s = "-" orelse s = ":"
40.182 +
40.183 +fun is_cmp s = s = "<" orelse s = ">" orelse s = "<="
40.184 + orelse s = ">=" orelse s = "="
40.185 +
40.186 +fun is_symbol a =
40.187 + let
40.188 + val symbol_char = String.explode "!\"#$%&()/,.;?@_`'{}|~"
40.189 + fun is_symbol_char c = Char.isAlphaNum c orelse
40.190 + exists (fn d => d=c) symbol_char
40.191 + fun is_symbol_start c = is_symbol_char c andalso
40.192 + not (Char.isDigit c) andalso
40.193 + not (c= #".")
40.194 + val b = String.explode a
40.195 + in
40.196 + b <> [] andalso is_symbol_start (hd b) andalso
40.197 + forall is_symbol_char b
40.198 + end
40.199 +
40.200 +fun to_upper s = String.implode (map Char.toUpper (String.explode s))
40.201 +
40.202 +fun keyword x =
40.203 + let
40.204 + val a = to_upper x
40.205 + in
40.206 + if a = "BOUNDS" orelse a = "BOUND" then
40.207 + SOME "BOUNDS"
40.208 + else if a = "MINIMIZE" orelse a = "MINIMUM" orelse a = "MIN" then
40.209 + SOME "MINIMIZE"
40.210 + else if a = "MAXIMIZE" orelse a = "MAXIMUM" orelse a = "MAX" then
40.211 + SOME "MAXIMIZE"
40.212 + else if a = "ST" orelse a = "S.T." orelse a = "ST." then
40.213 + SOME "ST"
40.214 + else if a = "FREE" orelse a = "END" then
40.215 + SOME a
40.216 + else if a = "GENERAL" orelse a = "GENERALS" orelse a = "GEN" then
40.217 + SOME "GENERAL"
40.218 + else if a = "INTEGER" orelse a = "INTEGERS" orelse a = "INT" then
40.219 + SOME "INTEGER"
40.220 + else if a = "BINARY" orelse a = "BINARIES" orelse a = "BIN" then
40.221 + SOME "BINARY"
40.222 + else if a = "INF" orelse a = "INFINITY" then
40.223 + SOME "INF"
40.224 + else
40.225 + NONE
40.226 + end
40.227 +
40.228 +val TOKEN_ERROR = ~1
40.229 +val TOKEN_BLANK = 0
40.230 +val TOKEN_NUM = 1
40.231 +val TOKEN_DELIMITER = 2
40.232 +val TOKEN_SYMBOL = 3
40.233 +val TOKEN_LABEL = 4
40.234 +val TOKEN_CMP = 5
40.235 +val TOKEN_KEYWORD = 6
40.236 +val TOKEN_NL = 7
40.237 +
40.238 +(* tokenize takes a list of chars as argument and returns a list of
40.239 + int * string pairs, each string representing a "cplex token",
40.240 + and each int being one of TOKEN_NUM, TOKEN_DELIMITER, TOKEN_CMP
40.241 + or TOKEN_SYMBOL *)
40.242 +fun tokenize s =
40.243 + let
40.244 + val flist = [(is_NL, TOKEN_NL),
40.245 + (is_blank, TOKEN_BLANK),
40.246 + (is_num, TOKEN_NUM),
40.247 + (is_delimiter, TOKEN_DELIMITER),
40.248 + (is_cmp, TOKEN_CMP),
40.249 + (is_symbol, TOKEN_SYMBOL)]
40.250 + fun match_helper [] s = (fn _ => false, TOKEN_ERROR)
40.251 + | match_helper (f::fs) s =
40.252 + if ((fst f) s) then f else match_helper fs s
40.253 + fun match s = match_helper flist s
40.254 + fun tok s =
40.255 + if s = "" then [] else
40.256 + let
40.257 + val h = String.substring (s,0,1)
40.258 + val (f, j) = match h
40.259 + fun len i =
40.260 + if size s = i then i
40.261 + else if f (String.substring (s,0,i+1)) then
40.262 + len (i+1)
40.263 + else i
40.264 + in
40.265 + if j < 0 then
40.266 + (if h = "\\" then []
40.267 + else raise (Load_cplexFile ("token expected, found: "
40.268 + ^s)))
40.269 + else
40.270 + let
40.271 + val l = len 1
40.272 + val u = String.substring (s,0,l)
40.273 + val v = String.extract (s,l,NONE)
40.274 + in
40.275 + if j = 0 then tok v else (j, u) :: tok v
40.276 + end
40.277 + end
40.278 + in
40.279 + tok s
40.280 + end
40.281 +
40.282 +exception Tokenize of string;
40.283 +
40.284 +fun tokenize_general flist s =
40.285 + let
40.286 + fun match_helper [] s = raise (Tokenize s)
40.287 + | match_helper (f::fs) s =
40.288 + if ((fst f) s) then f else match_helper fs s
40.289 + fun match s = match_helper flist s
40.290 + fun tok s =
40.291 + if s = "" then [] else
40.292 + let
40.293 + val h = String.substring (s,0,1)
40.294 + val (f, j) = match h
40.295 + fun len i =
40.296 + if size s = i then i
40.297 + else if f (String.substring (s,0,i+1)) then
40.298 + len (i+1)
40.299 + else i
40.300 + val l = len 1
40.301 + in
40.302 + (j, String.substring (s,0,l)) :: tok (String.extract (s,l,NONE))
40.303 + end
40.304 + in
40.305 + tok s
40.306 + end
40.307 +
40.308 +fun load_cplexFile name =
40.309 + let
40.310 + val f = TextIO.openIn name
40.311 + val ignore_NL = Unsynchronized.ref true
40.312 + val rest = Unsynchronized.ref []
40.313 +
40.314 + fun is_symbol s c = (fst c) = TOKEN_SYMBOL andalso (to_upper (snd c)) = s
40.315 +
40.316 + fun readToken_helper () =
40.317 + if length (!rest) > 0 then
40.318 + let val u = hd (!rest) in
40.319 + (
40.320 + rest := tl (!rest);
40.321 + SOME u
40.322 + )
40.323 + end
40.324 + else
40.325 + (case TextIO.inputLine f of
40.326 + NONE => NONE
40.327 + | SOME s =>
40.328 + let val t = tokenize s in
40.329 + if (length t >= 2 andalso
40.330 + snd(hd (tl t)) = ":")
40.331 + then
40.332 + rest := (TOKEN_LABEL, snd (hd t)) :: (tl (tl t))
40.333 + else if (length t >= 2) andalso is_symbol "SUBJECT" (hd (t))
40.334 + andalso is_symbol "TO" (hd (tl t))
40.335 + then
40.336 + rest := (TOKEN_SYMBOL, "ST") :: (tl (tl t))
40.337 + else
40.338 + rest := t;
40.339 + readToken_helper ()
40.340 + end)
40.341 +
40.342 + fun readToken_helper2 () =
40.343 + let val c = readToken_helper () in
40.344 + if c = NONE then NONE
40.345 + else if !ignore_NL andalso fst (the c) = TOKEN_NL then
40.346 + readToken_helper2 ()
40.347 + else if fst (the c) = TOKEN_SYMBOL
40.348 + andalso keyword (snd (the c)) <> NONE
40.349 + then SOME (TOKEN_KEYWORD, the (keyword (snd (the c))))
40.350 + else c
40.351 + end
40.352 +
40.353 + fun readToken () = readToken_helper2 ()
40.354 +
40.355 + fun pushToken a = rest := (a::(!rest))
40.356 +
40.357 + fun is_value token =
40.358 + fst token = TOKEN_NUM orelse (fst token = TOKEN_KEYWORD
40.359 + andalso snd token = "INF")
40.360 +
40.361 + fun get_value token =
40.362 + if fst token = TOKEN_NUM then
40.363 + cplexNum (snd token)
40.364 + else if fst token = TOKEN_KEYWORD andalso snd token = "INF"
40.365 + then
40.366 + cplexInf
40.367 + else
40.368 + raise (Load_cplexFile "num expected")
40.369 +
40.370 + fun readTerm_Product only_num =
40.371 + let val c = readToken () in
40.372 + if c = NONE then NONE
40.373 + else if fst (the c) = TOKEN_SYMBOL
40.374 + then (
40.375 + if only_num then (pushToken (the c); NONE)
40.376 + else SOME (cplexVar (snd (the c)))
40.377 + )
40.378 + else if only_num andalso is_value (the c) then
40.379 + SOME (get_value (the c))
40.380 + else if is_value (the c) then
40.381 + let val t1 = get_value (the c)
40.382 + val d = readToken ()
40.383 + in
40.384 + if d = NONE then SOME t1
40.385 + else if fst (the d) = TOKEN_SYMBOL then
40.386 + SOME (cplexProd (t1, cplexVar (snd (the d))))
40.387 + else
40.388 + (pushToken (the d); SOME t1)
40.389 + end
40.390 + else (pushToken (the c); NONE)
40.391 + end
40.392 +
40.393 + fun readTerm_Signed only_signed only_num =
40.394 + let
40.395 + val c = readToken ()
40.396 + in
40.397 + if c = NONE then NONE
40.398 + else
40.399 + let val d = the c in
40.400 + if d = (TOKEN_DELIMITER, "+") then
40.401 + readTerm_Product only_num
40.402 + else if d = (TOKEN_DELIMITER, "-") then
40.403 + SOME (cplexNeg (the (readTerm_Product
40.404 + only_num)))
40.405 + else (pushToken d;
40.406 + if only_signed then NONE
40.407 + else readTerm_Product only_num)
40.408 + end
40.409 + end
40.410 +
40.411 + fun readTerm_Sum first_signed =
40.412 + let val c = readTerm_Signed first_signed false in
40.413 + if c = NONE then [] else (the c)::(readTerm_Sum true)
40.414 + end
40.415 +
40.416 + fun readTerm () =
40.417 + let val c = readTerm_Sum false in
40.418 + if c = [] then NONE
40.419 + else if tl c = [] then SOME (hd c)
40.420 + else SOME (cplexSum c)
40.421 + end
40.422 +
40.423 + fun readLabeledTerm () =
40.424 + let val c = readToken () in
40.425 + if c = NONE then (NONE, NONE)
40.426 + else if fst (the c) = TOKEN_LABEL then
40.427 + let val t = readTerm () in
40.428 + if t = NONE then
40.429 + raise (Load_cplexFile ("term after label "^
40.430 + (snd (the c))^
40.431 + " expected"))
40.432 + else (SOME (snd (the c)), t)
40.433 + end
40.434 + else (pushToken (the c); (NONE, readTerm ()))
40.435 + end
40.436 +
40.437 + fun readGoal () =
40.438 + let
40.439 + val g = readToken ()
40.440 + in
40.441 + if g = SOME (TOKEN_KEYWORD, "MAXIMIZE") then
40.442 + cplexMaximize (the (snd (readLabeledTerm ())))
40.443 + else if g = SOME (TOKEN_KEYWORD, "MINIMIZE") then
40.444 + cplexMinimize (the (snd (readLabeledTerm ())))
40.445 + else raise (Load_cplexFile "MAXIMIZE or MINIMIZE expected")
40.446 + end
40.447 +
40.448 + fun str2cmp b =
40.449 + (case b of
40.450 + "<" => cplexLe
40.451 + | "<=" => cplexLeq
40.452 + | ">" => cplexGe
40.453 + | ">=" => cplexGeq
40.454 + | "=" => cplexEq
40.455 + | _ => raise (Load_cplexFile (b^" is no TOKEN_CMP")))
40.456 +
40.457 + fun readConstraint () =
40.458 + let
40.459 + val t = readLabeledTerm ()
40.460 + fun make_constraint b t1 t2 =
40.461 + cplexConstr
40.462 + (str2cmp b,
40.463 + (t1, t2))
40.464 + in
40.465 + if snd t = NONE then NONE
40.466 + else
40.467 + let val c = readToken () in
40.468 + if c = NONE orelse fst (the c) <> TOKEN_CMP
40.469 + then raise (Load_cplexFile "TOKEN_CMP expected")
40.470 + else
40.471 + let val n = readTerm_Signed false true in
40.472 + if n = NONE then
40.473 + raise (Load_cplexFile "num expected")
40.474 + else
40.475 + SOME (fst t,
40.476 + make_constraint (snd (the c))
40.477 + (the (snd t))
40.478 + (the n))
40.479 + end
40.480 + end
40.481 + end
40.482 +
40.483 + fun readST () =
40.484 + let
40.485 + fun readbody () =
40.486 + let val t = readConstraint () in
40.487 + if t = NONE then []
40.488 + else if (is_normed_Constr (snd (the t))) then
40.489 + (the t)::(readbody ())
40.490 + else if (fst (the t) <> NONE) then
40.491 + raise (Load_cplexFile
40.492 + ("constraint '"^(the (fst (the t)))^
40.493 + "'is not normed"))
40.494 + else
40.495 + raise (Load_cplexFile
40.496 + "constraint is not normed")
40.497 + end
40.498 + in
40.499 + if readToken () = SOME (TOKEN_KEYWORD, "ST")
40.500 + then
40.501 + readbody ()
40.502 + else
40.503 + raise (Load_cplexFile "ST expected")
40.504 + end
40.505 +
40.506 + fun readCmp () =
40.507 + let val c = readToken () in
40.508 + if c = NONE then NONE
40.509 + else if fst (the c) = TOKEN_CMP then
40.510 + SOME (str2cmp (snd (the c)))
40.511 + else (pushToken (the c); NONE)
40.512 + end
40.513 +
40.514 + fun skip_NL () =
40.515 + let val c = readToken () in
40.516 + if c <> NONE andalso fst (the c) = TOKEN_NL then
40.517 + skip_NL ()
40.518 + else
40.519 + (pushToken (the c); ())
40.520 + end
40.521 +
40.522 + fun make_bounds c t1 t2 =
40.523 + cplexBound (t1, c, t2)
40.524 +
40.525 + fun readBound () =
40.526 + let
40.527 + val _ = skip_NL ()
40.528 + val t1 = readTerm ()
40.529 + in
40.530 + if t1 = NONE then NONE
40.531 + else
40.532 + let
40.533 + val c1 = readCmp ()
40.534 + in
40.535 + if c1 = NONE then
40.536 + let
40.537 + val c = readToken ()
40.538 + in
40.539 + if c = SOME (TOKEN_KEYWORD, "FREE") then
40.540 + SOME (
40.541 + cplexBounds (cplexNeg cplexInf,
40.542 + cplexLeq,
40.543 + the t1,
40.544 + cplexLeq,
40.545 + cplexInf))
40.546 + else
40.547 + raise (Load_cplexFile "FREE expected")
40.548 + end
40.549 + else
40.550 + let
40.551 + val t2 = readTerm ()
40.552 + in
40.553 + if t2 = NONE then
40.554 + raise (Load_cplexFile "term expected")
40.555 + else
40.556 + let val c2 = readCmp () in
40.557 + if c2 = NONE then
40.558 + SOME (make_bounds (the c1)
40.559 + (the t1)
40.560 + (the t2))
40.561 + else
40.562 + SOME (
40.563 + cplexBounds (the t1,
40.564 + the c1,
40.565 + the t2,
40.566 + the c2,
40.567 + the (readTerm())))
40.568 + end
40.569 + end
40.570 + end
40.571 + end
40.572 +
40.573 + fun readBounds () =
40.574 + let
40.575 + fun makestring _ = "?"
40.576 + fun readbody () =
40.577 + let
40.578 + val b = readBound ()
40.579 + in
40.580 + if b = NONE then []
40.581 + else if (is_normed_Bounds (the b)) then
40.582 + (the b)::(readbody())
40.583 + else (
40.584 + raise (Load_cplexFile
40.585 + ("bounds are not normed in: "^
40.586 + (makestring (the b)))))
40.587 + end
40.588 + in
40.589 + if readToken () = SOME (TOKEN_KEYWORD, "BOUNDS") then
40.590 + readbody ()
40.591 + else raise (Load_cplexFile "BOUNDS expected")
40.592 + end
40.593 +
40.594 + fun readEnd () =
40.595 + if readToken () = SOME (TOKEN_KEYWORD, "END") then ()
40.596 + else raise (Load_cplexFile "END expected")
40.597 +
40.598 + val result_Goal = readGoal ()
40.599 + val result_ST = readST ()
40.600 + val _ = ignore_NL := false
40.601 + val result_Bounds = readBounds ()
40.602 + val _ = ignore_NL := true
40.603 + val _ = readEnd ()
40.604 + val _ = TextIO.closeIn f
40.605 + in
40.606 + cplexProg (name, result_Goal, result_ST, result_Bounds)
40.607 + end
40.608 +
40.609 +fun save_cplexFile filename (cplexProg (_, goal, constraints, bounds)) =
40.610 + let
40.611 + val f = TextIO.openOut filename
40.612 +
40.613 + fun basic_write s = TextIO.output(f, s)
40.614 +
40.615 + val linebuf = Unsynchronized.ref ""
40.616 + fun buf_flushline s =
40.617 + (basic_write (!linebuf);
40.618 + basic_write "\n";
40.619 + linebuf := s)
40.620 + fun buf_add s = linebuf := (!linebuf) ^ s
40.621 +
40.622 + fun write s =
40.623 + if (String.size s) + (String.size (!linebuf)) >= 250 then
40.624 + buf_flushline (" "^s)
40.625 + else
40.626 + buf_add s
40.627 +
40.628 + fun writeln s = (buf_add s; buf_flushline "")
40.629 +
40.630 + fun write_term (cplexVar x) = write x
40.631 + | write_term (cplexNum x) = write x
40.632 + | write_term cplexInf = write "inf"
40.633 + | write_term (cplexProd (cplexNum "1", b)) = write_term b
40.634 + | write_term (cplexProd (a, b)) =
40.635 + (write_term a; write " "; write_term b)
40.636 + | write_term (cplexNeg x) = (write " - "; write_term x)
40.637 + | write_term (cplexSum ts) = write_terms ts
40.638 + and write_terms [] = ()
40.639 + | write_terms (t::ts) =
40.640 + (if (not (is_Neg t)) then write " + " else ();
40.641 + write_term t; write_terms ts)
40.642 +
40.643 + fun write_goal (cplexMaximize term) =
40.644 + (writeln "MAXIMIZE"; write_term term; writeln "")
40.645 + | write_goal (cplexMinimize term) =
40.646 + (writeln "MINIMIZE"; write_term term; writeln "")
40.647 +
40.648 + fun write_cmp cplexLe = write "<"
40.649 + | write_cmp cplexLeq = write "<="
40.650 + | write_cmp cplexEq = write "="
40.651 + | write_cmp cplexGe = write ">"
40.652 + | write_cmp cplexGeq = write ">="
40.653 +
40.654 + fun write_constr (cplexConstr (cmp, (a,b))) =
40.655 + (write_term a;
40.656 + write " ";
40.657 + write_cmp cmp;
40.658 + write " ";
40.659 + write_term b)
40.660 +
40.661 + fun write_constraints [] = ()
40.662 + | write_constraints (c::cs) =
40.663 + (if (fst c <> NONE)
40.664 + then
40.665 + (write (the (fst c)); write ": ")
40.666 + else
40.667 + ();
40.668 + write_constr (snd c);
40.669 + writeln "";
40.670 + write_constraints cs)
40.671 +
40.672 + fun write_bounds [] = ()
40.673 + | write_bounds ((cplexBounds (t1,c1,t2,c2,t3))::bs) =
40.674 + ((if t1 = cplexNeg cplexInf andalso t3 = cplexInf
40.675 + andalso (c1 = cplexLeq orelse c1 = cplexLe)
40.676 + andalso (c2 = cplexLeq orelse c2 = cplexLe)
40.677 + then
40.678 + (write_term t2; write " free")
40.679 + else
40.680 + (write_term t1; write " "; write_cmp c1; write " ";
40.681 + write_term t2; write " "; write_cmp c2; write " ";
40.682 + write_term t3)
40.683 + ); writeln ""; write_bounds bs)
40.684 + | write_bounds ((cplexBound (t1, c, t2)) :: bs) =
40.685 + (write_term t1; write " ";
40.686 + write_cmp c; write " ";
40.687 + write_term t2; writeln ""; write_bounds bs)
40.688 +
40.689 + val _ = write_goal goal
40.690 + val _ = (writeln ""; writeln "ST")
40.691 + val _ = write_constraints constraints
40.692 + val _ = (writeln ""; writeln "BOUNDS")
40.693 + val _ = write_bounds bounds
40.694 + val _ = (writeln ""; writeln "END")
40.695 + val _ = TextIO.closeOut f
40.696 + in
40.697 + ()
40.698 + end
40.699 +
40.700 +fun norm_Constr (constr as cplexConstr (c, (t1, t2))) =
40.701 + if not (modulo_signed is_Num t2) andalso
40.702 + modulo_signed is_Num t1
40.703 + then
40.704 + [cplexConstr (rev_cmp c, (t2, t1))]
40.705 + else if (c = cplexLe orelse c = cplexLeq) andalso
40.706 + (t1 = (cplexNeg cplexInf) orelse t2 = cplexInf)
40.707 + then
40.708 + []
40.709 + else if (c = cplexGe orelse c = cplexGeq) andalso
40.710 + (t1 = cplexInf orelse t2 = cplexNeg cplexInf)
40.711 + then
40.712 + []
40.713 + else
40.714 + [constr]
40.715 +
40.716 +fun bound2constr (cplexBounds (t1,c1,t2,c2,t3)) =
40.717 + (norm_Constr(cplexConstr (c1, (t1, t2))))
40.718 + @ (norm_Constr(cplexConstr (c2, (t2, t3))))
40.719 + | bound2constr (cplexBound (t1, cplexEq, t2)) =
40.720 + (norm_Constr(cplexConstr (cplexLeq, (t1, t2))))
40.721 + @ (norm_Constr(cplexConstr (cplexLeq, (t2, t1))))
40.722 + | bound2constr (cplexBound (t1, c1, t2)) =
40.723 + norm_Constr(cplexConstr (c1, (t1,t2)))
40.724 +
40.725 +val emptyset = Symtab.empty
40.726 +
40.727 +fun singleton v = Symtab.update (v, ()) emptyset
40.728 +
40.729 +fun merge a b = Symtab.merge (op =) (a, b)
40.730 +
40.731 +fun mergemap f ts = fold (fn x => fn table => merge table (f x)) ts Symtab.empty
40.732 +
40.733 +fun diff a b = Symtab.fold (Symtab.delete_safe o fst) b a
40.734 +
40.735 +fun collect_vars (cplexVar v) = singleton v
40.736 + | collect_vars (cplexNeg t) = collect_vars t
40.737 + | collect_vars (cplexProd (t1, t2)) =
40.738 + merge (collect_vars t1) (collect_vars t2)
40.739 + | collect_vars (cplexSum ts) = mergemap collect_vars ts
40.740 + | collect_vars _ = emptyset
40.741 +
40.742 +(* Eliminates all nonfree bounds from the linear program and produces an
40.743 + equivalent program with only free bounds
40.744 + IF for the input program P holds: is_normed_cplexProg P *)
40.745 +fun elim_nonfree_bounds (cplexProg (name, goal, constraints, bounds)) =
40.746 + let
40.747 + fun collect_constr_vars (_, cplexConstr (_, (t1,_))) =
40.748 + (collect_vars t1)
40.749 +
40.750 + val cvars = merge (collect_vars (term_of_goal goal))
40.751 + (mergemap collect_constr_vars constraints)
40.752 +
40.753 + fun collect_lower_bounded_vars
40.754 + (cplexBounds (_, _, cplexVar v, _, _)) =
40.755 + singleton v
40.756 + | collect_lower_bounded_vars
40.757 + (cplexBound (_, cplexLe, cplexVar v)) =
40.758 + singleton v
40.759 + | collect_lower_bounded_vars
40.760 + (cplexBound (_, cplexLeq, cplexVar v)) =
40.761 + singleton v
40.762 + | collect_lower_bounded_vars
40.763 + (cplexBound (cplexVar v, cplexGe,_)) =
40.764 + singleton v
40.765 + | collect_lower_bounded_vars
40.766 + (cplexBound (cplexVar v, cplexGeq, _)) =
40.767 + singleton v
40.768 + | collect_lower_bounded_vars
40.769 + (cplexBound (cplexVar v, cplexEq, _)) =
40.770 + singleton v
40.771 + | collect_lower_bounded_vars _ = emptyset
40.772 +
40.773 + val lvars = mergemap collect_lower_bounded_vars bounds
40.774 + val positive_vars = diff cvars lvars
40.775 + val zero = cplexNum "0"
40.776 +
40.777 + fun make_pos_constr v =
40.778 + (NONE, cplexConstr (cplexGeq, ((cplexVar v), zero)))
40.779 +
40.780 + fun make_free_bound v =
40.781 + cplexBounds (cplexNeg cplexInf, cplexLeq,
40.782 + cplexVar v, cplexLeq,
40.783 + cplexInf)
40.784 +
40.785 + val pos_constrs = rev (Symtab.fold
40.786 + (fn (k, _) => cons (make_pos_constr k))
40.787 + positive_vars [])
40.788 + val bound_constrs = map (pair NONE)
40.789 + (maps bound2constr bounds)
40.790 + val constraints' = constraints @ pos_constrs @ bound_constrs
40.791 + val bounds' = rev (Symtab.fold (fn (v, _) => cons (make_free_bound v)) cvars []);
40.792 + in
40.793 + cplexProg (name, goal, constraints', bounds')
40.794 + end
40.795 +
40.796 +fun relax_strict_ineqs (cplexProg (name, goals, constrs, bounds)) =
40.797 + let
40.798 + fun relax cplexLe = cplexLeq
40.799 + | relax cplexGe = cplexGeq
40.800 + | relax x = x
40.801 +
40.802 + fun relax_constr (n, cplexConstr(c, (t1, t2))) =
40.803 + (n, cplexConstr(relax c, (t1, t2)))
40.804 +
40.805 + fun relax_bounds (cplexBounds (t1, c1, t2, c2, t3)) =
40.806 + cplexBounds (t1, relax c1, t2, relax c2, t3)
40.807 + | relax_bounds (cplexBound (t1, c, t2)) =
40.808 + cplexBound (t1, relax c, t2)
40.809 + in
40.810 + cplexProg (name,
40.811 + goals,
40.812 + map relax_constr constrs,
40.813 + map relax_bounds bounds)
40.814 + end
40.815 +
40.816 +datatype cplexResult = Unbounded
40.817 + | Infeasible
40.818 + | Undefined
40.819 + | Optimal of string * ((string * string) list)
40.820 +
40.821 +fun is_separator x = forall (fn c => c = #"-") (String.explode x)
40.822 +
40.823 +fun is_sign x = (x = "+" orelse x = "-")
40.824 +
40.825 +fun is_colon x = (x = ":")
40.826 +
40.827 +fun is_resultsymbol a =
40.828 + let
40.829 + val symbol_char = String.explode "!\"#$%&()/,.;?@_`'{}|~-"
40.830 + fun is_symbol_char c = Char.isAlphaNum c orelse
40.831 + exists (fn d => d=c) symbol_char
40.832 + fun is_symbol_start c = is_symbol_char c andalso
40.833 + not (Char.isDigit c) andalso
40.834 + not (c= #".") andalso
40.835 + not (c= #"-")
40.836 + val b = String.explode a
40.837 + in
40.838 + b <> [] andalso is_symbol_start (hd b) andalso
40.839 + forall is_symbol_char b
40.840 + end
40.841 +
40.842 +val TOKEN_SIGN = 100
40.843 +val TOKEN_COLON = 101
40.844 +val TOKEN_SEPARATOR = 102
40.845 +
40.846 +fun load_glpkResult name =
40.847 + let
40.848 + val flist = [(is_NL, TOKEN_NL),
40.849 + (is_blank, TOKEN_BLANK),
40.850 + (is_num, TOKEN_NUM),
40.851 + (is_sign, TOKEN_SIGN),
40.852 + (is_colon, TOKEN_COLON),
40.853 + (is_cmp, TOKEN_CMP),
40.854 + (is_resultsymbol, TOKEN_SYMBOL),
40.855 + (is_separator, TOKEN_SEPARATOR)]
40.856 +
40.857 + val tokenize = tokenize_general flist
40.858 +
40.859 + val f = TextIO.openIn name
40.860 +
40.861 + val rest = Unsynchronized.ref []
40.862 +
40.863 + fun readToken_helper () =
40.864 + if length (!rest) > 0 then
40.865 + let val u = hd (!rest) in
40.866 + (
40.867 + rest := tl (!rest);
40.868 + SOME u
40.869 + )
40.870 + end
40.871 + else
40.872 + (case TextIO.inputLine f of
40.873 + NONE => NONE
40.874 + | SOME s => (rest := tokenize s; readToken_helper()))
40.875 +
40.876 + fun is_tt tok ty = (tok <> NONE andalso (fst (the tok)) = ty)
40.877 +
40.878 + fun pushToken a = if a = NONE then () else (rest := ((the a)::(!rest)))
40.879 +
40.880 + fun readToken () =
40.881 + let val t = readToken_helper () in
40.882 + if is_tt t TOKEN_BLANK then
40.883 + readToken ()
40.884 + else if is_tt t TOKEN_NL then
40.885 + let val t2 = readToken_helper () in
40.886 + if is_tt t2 TOKEN_SIGN then
40.887 + (pushToken (SOME (TOKEN_SEPARATOR, "-")); t)
40.888 + else
40.889 + (pushToken t2; t)
40.890 + end
40.891 + else if is_tt t TOKEN_SIGN then
40.892 + let val t2 = readToken_helper () in
40.893 + if is_tt t2 TOKEN_NUM then
40.894 + (SOME (TOKEN_NUM, (snd (the t))^(snd (the t2))))
40.895 + else
40.896 + (pushToken t2; t)
40.897 + end
40.898 + else
40.899 + t
40.900 + end
40.901 +
40.902 + fun readRestOfLine P =
40.903 + let
40.904 + val t = readToken ()
40.905 + in
40.906 + if is_tt t TOKEN_NL orelse t = NONE
40.907 + then P
40.908 + else readRestOfLine P
40.909 + end
40.910 +
40.911 + fun readHeader () =
40.912 + let
40.913 + fun readStatus () = readRestOfLine ("STATUS", snd (the (readToken ())))
40.914 + fun readObjective () = readRestOfLine ("OBJECTIVE", snd (the (readToken (); readToken (); readToken ())))
40.915 + val t1 = readToken ()
40.916 + val t2 = readToken ()
40.917 + in
40.918 + if is_tt t1 TOKEN_SYMBOL andalso is_tt t2 TOKEN_COLON
40.919 + then
40.920 + case to_upper (snd (the t1)) of
40.921 + "STATUS" => (readStatus ())::(readHeader ())
40.922 + | "OBJECTIVE" => (readObjective())::(readHeader ())
40.923 + | _ => (readRestOfLine (); readHeader ())
40.924 + else
40.925 + (pushToken t2; pushToken t1; [])
40.926 + end
40.927 +
40.928 + fun skip_until_sep () =
40.929 + let val x = readToken () in
40.930 + if is_tt x TOKEN_SEPARATOR then
40.931 + readRestOfLine ()
40.932 + else
40.933 + skip_until_sep ()
40.934 + end
40.935 +
40.936 + fun load_value () =
40.937 + let
40.938 + val t1 = readToken ()
40.939 + val t2 = readToken ()
40.940 + in
40.941 + if is_tt t1 TOKEN_NUM andalso is_tt t2 TOKEN_SYMBOL then
40.942 + let
40.943 + val t = readToken ()
40.944 + val state = if is_tt t TOKEN_NL then readToken () else t
40.945 + val _ = if is_tt state TOKEN_SYMBOL then () else raise (Load_cplexResult "state expected")
40.946 + val k = readToken ()
40.947 + in
40.948 + if is_tt k TOKEN_NUM then
40.949 + readRestOfLine (SOME (snd (the t2), snd (the k)))
40.950 + else
40.951 + raise (Load_cplexResult "number expected")
40.952 + end
40.953 + else
40.954 + (pushToken t2; pushToken t1; NONE)
40.955 + end
40.956 +
40.957 + fun load_values () =
40.958 + let val v = load_value () in
40.959 + if v = NONE then [] else (the v)::(load_values ())
40.960 + end
40.961 +
40.962 + val header = readHeader ()
40.963 +
40.964 + val result =
40.965 + case AList.lookup (op =) header "STATUS" of
40.966 + SOME "INFEASIBLE" => Infeasible
40.967 + | SOME "UNBOUNDED" => Unbounded
40.968 + | SOME "OPTIMAL" => Optimal (the (AList.lookup (op =) header "OBJECTIVE"),
40.969 + (skip_until_sep ();
40.970 + skip_until_sep ();
40.971 + load_values ()))
40.972 + | _ => Undefined
40.973 +
40.974 + val _ = TextIO.closeIn f
40.975 + in
40.976 + result
40.977 + end
40.978 + handle (Tokenize s) => raise (Load_cplexResult ("Tokenize: "^s))
40.979 + | Option => raise (Load_cplexResult "Option")
40.980 +
40.981 +fun load_cplexResult name =
40.982 + let
40.983 + val flist = [(is_NL, TOKEN_NL),
40.984 + (is_blank, TOKEN_BLANK),
40.985 + (is_num, TOKEN_NUM),
40.986 + (is_sign, TOKEN_SIGN),
40.987 + (is_colon, TOKEN_COLON),
40.988 + (is_cmp, TOKEN_CMP),
40.989 + (is_resultsymbol, TOKEN_SYMBOL)]
40.990 +
40.991 + val tokenize = tokenize_general flist
40.992 +
40.993 + val f = TextIO.openIn name
40.994 +
40.995 + val rest = Unsynchronized.ref []
40.996 +
40.997 + fun readToken_helper () =
40.998 + if length (!rest) > 0 then
40.999 + let val u = hd (!rest) in
40.1000 + (
40.1001 + rest := tl (!rest);
40.1002 + SOME u
40.1003 + )
40.1004 + end
40.1005 + else
40.1006 + (case TextIO.inputLine f of
40.1007 + NONE => NONE
40.1008 + | SOME s => (rest := tokenize s; readToken_helper()))
40.1009 +
40.1010 + fun is_tt tok ty = (tok <> NONE andalso (fst (the tok)) = ty)
40.1011 +
40.1012 + fun pushToken a = if a = NONE then () else (rest := ((the a)::(!rest)))
40.1013 +
40.1014 + fun readToken () =
40.1015 + let val t = readToken_helper () in
40.1016 + if is_tt t TOKEN_BLANK then
40.1017 + readToken ()
40.1018 + else if is_tt t TOKEN_SIGN then
40.1019 + let val t2 = readToken_helper () in
40.1020 + if is_tt t2 TOKEN_NUM then
40.1021 + (SOME (TOKEN_NUM, (snd (the t))^(snd (the t2))))
40.1022 + else
40.1023 + (pushToken t2; t)
40.1024 + end
40.1025 + else
40.1026 + t
40.1027 + end
40.1028 +
40.1029 + fun readRestOfLine P =
40.1030 + let
40.1031 + val t = readToken ()
40.1032 + in
40.1033 + if is_tt t TOKEN_NL orelse t = NONE
40.1034 + then P
40.1035 + else readRestOfLine P
40.1036 + end
40.1037 +
40.1038 + fun readHeader () =
40.1039 + let
40.1040 + fun readStatus () = readRestOfLine ("STATUS", snd (the (readToken ())))
40.1041 + fun readObjective () =
40.1042 + let
40.1043 + val t = readToken ()
40.1044 + in
40.1045 + if is_tt t TOKEN_SYMBOL andalso to_upper (snd (the t)) = "VALUE" then
40.1046 + readRestOfLine ("OBJECTIVE", snd (the (readToken())))
40.1047 + else
40.1048 + readRestOfLine ("OBJECTIVE_NAME", snd (the t))
40.1049 + end
40.1050 +
40.1051 + val t = readToken ()
40.1052 + in
40.1053 + if is_tt t TOKEN_SYMBOL then
40.1054 + case to_upper (snd (the t)) of
40.1055 + "STATUS" => (readStatus ())::(readHeader ())
40.1056 + | "OBJECTIVE" => (readObjective ())::(readHeader ())
40.1057 + | "SECTION" => (pushToken t; [])
40.1058 + | _ => (readRestOfLine (); readHeader ())
40.1059 + else
40.1060 + (readRestOfLine (); readHeader ())
40.1061 + end
40.1062 +
40.1063 + fun skip_nls () =
40.1064 + let val x = readToken () in
40.1065 + if is_tt x TOKEN_NL then
40.1066 + skip_nls ()
40.1067 + else
40.1068 + (pushToken x; ())
40.1069 + end
40.1070 +
40.1071 + fun skip_paragraph () =
40.1072 + if is_tt (readToken ()) TOKEN_NL then
40.1073 + (if is_tt (readToken ()) TOKEN_NL then
40.1074 + skip_nls ()
40.1075 + else
40.1076 + skip_paragraph ())
40.1077 + else
40.1078 + skip_paragraph ()
40.1079 +
40.1080 + fun load_value () =
40.1081 + let
40.1082 + val t1 = readToken ()
40.1083 + val t1 = if is_tt t1 TOKEN_SYMBOL andalso snd (the t1) = "A" then readToken () else t1
40.1084 + in
40.1085 + if is_tt t1 TOKEN_NUM then
40.1086 + let
40.1087 + val name = readToken ()
40.1088 + val status = readToken ()
40.1089 + val value = readToken ()
40.1090 + in
40.1091 + if is_tt name TOKEN_SYMBOL andalso
40.1092 + is_tt status TOKEN_SYMBOL andalso
40.1093 + is_tt value TOKEN_NUM
40.1094 + then
40.1095 + readRestOfLine (SOME (snd (the name), snd (the value)))
40.1096 + else
40.1097 + raise (Load_cplexResult "column line expected")
40.1098 + end
40.1099 + else
40.1100 + (pushToken t1; NONE)
40.1101 + end
40.1102 +
40.1103 + fun load_values () =
40.1104 + let val v = load_value () in
40.1105 + if v = NONE then [] else (the v)::(load_values ())
40.1106 + end
40.1107 +
40.1108 + val header = readHeader ()
40.1109 +
40.1110 + val result =
40.1111 + case AList.lookup (op =) header "STATUS" of
40.1112 + SOME "INFEASIBLE" => Infeasible
40.1113 + | SOME "NONOPTIMAL" => Unbounded
40.1114 + | SOME "OPTIMAL" => Optimal (the (AList.lookup (op =) header "OBJECTIVE"),
40.1115 + (skip_paragraph ();
40.1116 + skip_paragraph ();
40.1117 + skip_paragraph ();
40.1118 + skip_paragraph ();
40.1119 + skip_paragraph ();
40.1120 + load_values ()))
40.1121 + | _ => Undefined
40.1122 +
40.1123 + val _ = TextIO.closeIn f
40.1124 + in
40.1125 + result
40.1126 + end
40.1127 + handle (Tokenize s) => raise (Load_cplexResult ("Tokenize: "^s))
40.1128 + | Option => raise (Load_cplexResult "Option")
40.1129 +
40.1130 +exception Execute of string;
40.1131 +
40.1132 +fun tmp_file s = Path.implode (Path.expand (File.tmp_path (Path.basic s)));
40.1133 +fun wrap s = "\""^s^"\"";
40.1134 +
40.1135 +fun solve_glpk prog =
40.1136 + let
40.1137 + val name = string_of_int (Time.toMicroseconds (Time.now ()))
40.1138 + val lpname = tmp_file (name^".lp")
40.1139 + val resultname = tmp_file (name^".txt")
40.1140 + val _ = save_cplexFile lpname prog
40.1141 + val cplex_path = getenv "GLPK_PATH"
40.1142 + val cplex = if cplex_path = "" then "glpsol" else cplex_path
40.1143 + val command = (wrap cplex)^" --lpt "^(wrap lpname)^" --output "^(wrap resultname)
40.1144 + val answer = #1 (Isabelle_System.bash_output command)
40.1145 + in
40.1146 + let
40.1147 + val result = load_glpkResult resultname
40.1148 + val _ = OS.FileSys.remove lpname
40.1149 + val _ = OS.FileSys.remove resultname
40.1150 + in
40.1151 + result
40.1152 + end
40.1153 + handle (Load_cplexResult s) => raise (Execute ("Load_cplexResult: "^s^"\nExecute: "^answer))
40.1154 + | _ => raise (Execute answer) (* FIXME avoid handle _ *)
40.1155 + end
40.1156 +
40.1157 +fun solve_cplex prog =
40.1158 + let
40.1159 + fun write_script s lp r =
40.1160 + let
40.1161 + val f = TextIO.openOut s
40.1162 + val _ = TextIO.output (f, "read\n"^lp^"\noptimize\nwrite\n"^r^"\nquit")
40.1163 + val _ = TextIO.closeOut f
40.1164 + in
40.1165 + ()
40.1166 + end
40.1167 +
40.1168 + val name = string_of_int (Time.toMicroseconds (Time.now ()))
40.1169 + val lpname = tmp_file (name^".lp")
40.1170 + val resultname = tmp_file (name^".txt")
40.1171 + val scriptname = tmp_file (name^".script")
40.1172 + val _ = save_cplexFile lpname prog
40.1173 + val _ = write_script scriptname lpname resultname
40.1174 + in
40.1175 + let
40.1176 + val result = load_cplexResult resultname
40.1177 + val _ = OS.FileSys.remove lpname
40.1178 + val _ = OS.FileSys.remove resultname
40.1179 + val _ = OS.FileSys.remove scriptname
40.1180 + in
40.1181 + result
40.1182 + end
40.1183 + end
40.1184 +
40.1185 +fun solve prog =
40.1186 + case get_solver () of
40.1187 + SOLVER_DEFAULT =>
40.1188 + (case getenv "LP_SOLVER" of
40.1189 + "CPLEX" => solve_cplex prog
40.1190 + | "GLPK" => solve_glpk prog
40.1191 + | _ => raise (Execute ("LP_SOLVER must be set to CPLEX or to GLPK")))
40.1192 + | SOLVER_CPLEX => solve_cplex prog
40.1193 + | SOLVER_GLPK => solve_glpk prog
40.1194 +
40.1195 +end;
41.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
41.2 +++ b/src/HOL/Matrix_LP/FloatSparseMatrixBuilder.ML Sat Mar 17 12:52:40 2012 +0100
41.3 @@ -0,0 +1,284 @@
41.4 +(* Title: HOL/Matrix/FloatSparseMatrixBuilder.ML
41.5 + Author: Steven Obua
41.6 +*)
41.7 +
41.8 +signature FLOAT_SPARSE_MATRIX_BUILDER =
41.9 +sig
41.10 + include MATRIX_BUILDER
41.11 +
41.12 + structure cplex : CPLEX
41.13 +
41.14 + type float = Float.float
41.15 + val approx_value : int -> (float -> float) -> string -> term * term
41.16 + val approx_vector : int -> (float -> float) -> vector -> term * term
41.17 + val approx_matrix : int -> (float -> float) -> matrix -> term * term
41.18 +
41.19 + val mk_spvec_entry : int -> float -> term
41.20 + val mk_spvec_entry' : int -> term -> term
41.21 + val mk_spmat_entry : int -> term -> term
41.22 + val spvecT: typ
41.23 + val spmatT: typ
41.24 +
41.25 + val v_elem_at : vector -> int -> string option
41.26 + val m_elem_at : matrix -> int -> vector option
41.27 + val v_only_elem : vector -> int option
41.28 + val v_fold : (int * string -> 'a -> 'a) -> vector -> 'a -> 'a
41.29 + val m_fold : (int * vector -> 'a -> 'a) -> matrix -> 'a -> 'a
41.30 +
41.31 + val transpose_matrix : matrix -> matrix
41.32 +
41.33 + val cut_vector : int -> vector -> vector
41.34 + val cut_matrix : vector -> int option -> matrix -> matrix
41.35 +
41.36 + val delete_matrix : int list -> matrix -> matrix
41.37 + val cut_matrix' : int list -> matrix -> matrix
41.38 + val delete_vector : int list -> vector -> vector
41.39 + val cut_vector' : int list -> vector -> vector
41.40 +
41.41 + val indices_of_matrix : matrix -> int list
41.42 + val indices_of_vector : vector -> int list
41.43 +
41.44 + (* cplexProg c A b *)
41.45 + val cplexProg : vector -> matrix -> vector -> cplex.cplexProg * (string -> int)
41.46 + (* dual_cplexProg c A b *)
41.47 + val dual_cplexProg : vector -> matrix -> vector -> cplex.cplexProg * (string -> int)
41.48 +end;
41.49 +
41.50 +structure FloatSparseMatrixBuilder : FLOAT_SPARSE_MATRIX_BUILDER =
41.51 +struct
41.52 +
41.53 +type float = Float.float
41.54 +structure Inttab = Table(type key = int val ord = rev_order o int_ord);
41.55 +
41.56 +type vector = string Inttab.table
41.57 +type matrix = vector Inttab.table
41.58 +
41.59 +val spvec_elemT = HOLogic.mk_prodT (HOLogic.natT, HOLogic.realT);
41.60 +val spvecT = HOLogic.listT spvec_elemT;
41.61 +val spmat_elemT = HOLogic.mk_prodT (HOLogic.natT, spvecT);
41.62 +val spmatT = HOLogic.listT spmat_elemT;
41.63 +
41.64 +fun approx_value prec f =
41.65 + FloatArith.approx_float prec (fn (x, y) => (f x, f y));
41.66 +
41.67 +fun mk_spvec_entry i f =
41.68 + HOLogic.mk_prod (HOLogic.mk_number HOLogic.natT i, FloatArith.mk_float f);
41.69 +
41.70 +fun mk_spvec_entry' i x =
41.71 + HOLogic.mk_prod (HOLogic.mk_number HOLogic.natT i, x);
41.72 +
41.73 +fun mk_spmat_entry i e =
41.74 + HOLogic.mk_prod (HOLogic.mk_number HOLogic.natT i, e);
41.75 +
41.76 +fun approx_vector prec pprt vector =
41.77 + let
41.78 + fun app (index, s) (lower, upper) =
41.79 + let
41.80 + val (flower, fupper) = approx_value prec pprt s
41.81 + val index = HOLogic.mk_number HOLogic.natT index
41.82 + val elower = HOLogic.mk_prod (index, flower)
41.83 + val eupper = HOLogic.mk_prod (index, fupper)
41.84 + in (elower :: lower, eupper :: upper) end;
41.85 + in
41.86 + pairself (HOLogic.mk_list spvec_elemT) (Inttab.fold app vector ([], []))
41.87 + end;
41.88 +
41.89 +fun approx_matrix prec pprt vector =
41.90 + let
41.91 + fun app (index, v) (lower, upper) =
41.92 + let
41.93 + val (flower, fupper) = approx_vector prec pprt v
41.94 + val index = HOLogic.mk_number HOLogic.natT index
41.95 + val elower = HOLogic.mk_prod (index, flower)
41.96 + val eupper = HOLogic.mk_prod (index, fupper)
41.97 + in (elower :: lower, eupper :: upper) end;
41.98 + in
41.99 + pairself (HOLogic.mk_list spmat_elemT) (Inttab.fold app vector ([], []))
41.100 + end;
41.101 +
41.102 +exception Nat_expected of int;
41.103 +
41.104 +val zero_interval = approx_value 1 I "0"
41.105 +
41.106 +fun set_elem vector index str =
41.107 + if index < 0 then
41.108 + raise (Nat_expected index)
41.109 + else if (approx_value 1 I str) = zero_interval then
41.110 + vector
41.111 + else
41.112 + Inttab.update (index, str) vector
41.113 +
41.114 +fun set_vector matrix index vector =
41.115 + if index < 0 then
41.116 + raise (Nat_expected index)
41.117 + else if Inttab.is_empty vector then
41.118 + matrix
41.119 + else
41.120 + Inttab.update (index, vector) matrix
41.121 +
41.122 +val empty_matrix = Inttab.empty
41.123 +val empty_vector = Inttab.empty
41.124 +
41.125 +(* dual stuff *)
41.126 +
41.127 +structure cplex = Cplex
41.128 +
41.129 +fun transpose_matrix matrix =
41.130 + let
41.131 + fun upd j (i, s) =
41.132 + Inttab.map_default (i, Inttab.empty) (Inttab.update (j, s));
41.133 + fun updm (j, v) = Inttab.fold (upd j) v;
41.134 + in Inttab.fold updm matrix empty_matrix end;
41.135 +
41.136 +exception No_name of string;
41.137 +
41.138 +exception Superfluous_constr_right_hand_sides
41.139 +
41.140 +fun cplexProg c A b =
41.141 + let
41.142 + val ytable = Unsynchronized.ref Inttab.empty
41.143 + fun indexof s =
41.144 + if String.size s = 0 then raise (No_name s)
41.145 + else case Int.fromString (String.extract(s, 1, NONE)) of
41.146 + SOME i => i | NONE => raise (No_name s)
41.147 +
41.148 + fun nameof i =
41.149 + let
41.150 + val s = "x" ^ string_of_int i
41.151 + val _ = Unsynchronized.change ytable (Inttab.update (i, s))
41.152 + in
41.153 + s
41.154 + end
41.155 +
41.156 + fun split_numstr s =
41.157 + if String.isPrefix "-" s then (false,String.extract(s, 1, NONE))
41.158 + else if String.isPrefix "+" s then (true, String.extract(s, 1, NONE))
41.159 + else (true, s)
41.160 +
41.161 + fun mk_term index s =
41.162 + let
41.163 + val (p, s) = split_numstr s
41.164 + val prod = cplex.cplexProd (cplex.cplexNum s, cplex.cplexVar (nameof index))
41.165 + in
41.166 + if p then prod else cplex.cplexNeg prod
41.167 + end
41.168 +
41.169 + fun vec2sum vector =
41.170 + cplex.cplexSum (Inttab.fold (fn (index, s) => fn list => (mk_term index s) :: list) vector [])
41.171 +
41.172 + fun mk_constr index vector c =
41.173 + let
41.174 + val s = case Inttab.lookup c index of SOME s => s | NONE => "0"
41.175 + val (p, s) = split_numstr s
41.176 + val num = if p then cplex.cplexNum s else cplex.cplexNeg (cplex.cplexNum s)
41.177 + in
41.178 + (NONE, cplex.cplexConstr (cplex.cplexLeq, (vec2sum vector, num)))
41.179 + end
41.180 +
41.181 + fun delete index c = Inttab.delete index c handle Inttab.UNDEF _ => c
41.182 +
41.183 + val (list, b) = Inttab.fold
41.184 + (fn (index, v) => fn (list, c) => ((mk_constr index v c)::list, delete index c))
41.185 + A ([], b)
41.186 + val _ = if Inttab.is_empty b then () else raise Superfluous_constr_right_hand_sides
41.187 +
41.188 + fun mk_free y = cplex.cplexBounds (cplex.cplexNeg cplex.cplexInf, cplex.cplexLeq,
41.189 + cplex.cplexVar y, cplex.cplexLeq,
41.190 + cplex.cplexInf)
41.191 +
41.192 + val yvars = Inttab.fold (fn (_, y) => fn l => (mk_free y)::l) (!ytable) []
41.193 +
41.194 + val prog = cplex.cplexProg ("original", cplex.cplexMaximize (vec2sum c), list, yvars)
41.195 + in
41.196 + (prog, indexof)
41.197 + end
41.198 +
41.199 +
41.200 +fun dual_cplexProg c A b =
41.201 + let
41.202 + fun indexof s =
41.203 + if String.size s = 0 then raise (No_name s)
41.204 + else case Int.fromString (String.extract(s, 1, NONE)) of
41.205 + SOME i => i | NONE => raise (No_name s)
41.206 +
41.207 + fun nameof i = "y" ^ string_of_int i
41.208 +
41.209 + fun split_numstr s =
41.210 + if String.isPrefix "-" s then (false,String.extract(s, 1, NONE))
41.211 + else if String.isPrefix "+" s then (true, String.extract(s, 1, NONE))
41.212 + else (true, s)
41.213 +
41.214 + fun mk_term index s =
41.215 + let
41.216 + val (p, s) = split_numstr s
41.217 + val prod = cplex.cplexProd (cplex.cplexNum s, cplex.cplexVar (nameof index))
41.218 + in
41.219 + if p then prod else cplex.cplexNeg prod
41.220 + end
41.221 +
41.222 + fun vec2sum vector =
41.223 + cplex.cplexSum (Inttab.fold (fn (index, s) => fn list => (mk_term index s)::list) vector [])
41.224 +
41.225 + fun mk_constr index vector c =
41.226 + let
41.227 + val s = case Inttab.lookup c index of SOME s => s | NONE => "0"
41.228 + val (p, s) = split_numstr s
41.229 + val num = if p then cplex.cplexNum s else cplex.cplexNeg (cplex.cplexNum s)
41.230 + in
41.231 + (NONE, cplex.cplexConstr (cplex.cplexEq, (vec2sum vector, num)))
41.232 + end
41.233 +
41.234 + fun delete index c = Inttab.delete index c handle Inttab.UNDEF _ => c
41.235 +
41.236 + val (list, c) = Inttab.fold
41.237 + (fn (index, v) => fn (list, c) => ((mk_constr index v c)::list, delete index c))
41.238 + (transpose_matrix A) ([], c)
41.239 + val _ = if Inttab.is_empty c then () else raise Superfluous_constr_right_hand_sides
41.240 +
41.241 + val prog = cplex.cplexProg ("dual", cplex.cplexMinimize (vec2sum b), list, [])
41.242 + in
41.243 + (prog, indexof)
41.244 + end
41.245 +
41.246 +fun cut_vector size v =
41.247 + let
41.248 + val count = Unsynchronized.ref 0;
41.249 + fun app (i, s) = if (!count < size) then
41.250 + (count := !count +1 ; Inttab.update (i, s))
41.251 + else I
41.252 + in
41.253 + Inttab.fold app v empty_vector
41.254 + end
41.255 +
41.256 +fun cut_matrix vfilter vsize m =
41.257 + let
41.258 + fun app (i, v) =
41.259 + if is_none (Inttab.lookup vfilter i) then I
41.260 + else case vsize
41.261 + of NONE => Inttab.update (i, v)
41.262 + | SOME s => Inttab.update (i, cut_vector s v)
41.263 + in Inttab.fold app m empty_matrix end
41.264 +
41.265 +fun v_elem_at v i = Inttab.lookup v i
41.266 +fun m_elem_at m i = Inttab.lookup m i
41.267 +
41.268 +fun v_only_elem v =
41.269 + case Inttab.min_key v of
41.270 + NONE => NONE
41.271 + | SOME vmin => (case Inttab.max_key v of
41.272 + NONE => SOME vmin
41.273 + | SOME vmax => if vmin = vmax then SOME vmin else NONE)
41.274 +
41.275 +fun v_fold f = Inttab.fold f;
41.276 +fun m_fold f = Inttab.fold f;
41.277 +
41.278 +fun indices_of_vector v = Inttab.keys v
41.279 +fun indices_of_matrix m = Inttab.keys m
41.280 +fun delete_vector indices v = fold Inttab.delete indices v
41.281 +fun delete_matrix indices m = fold Inttab.delete indices m
41.282 +fun cut_matrix' indices _ = fold (fn i => fn m => (case Inttab.lookup m i of NONE => m | SOME v => Inttab.update (i, v) m)) indices Inttab.empty
41.283 +fun cut_vector' indices _ = fold (fn i => fn v => (case Inttab.lookup v i of NONE => v | SOME x => Inttab.update (i, x) v)) indices Inttab.empty
41.284 +
41.285 +
41.286 +
41.287 +end;
42.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
42.2 +++ b/src/HOL/Matrix_LP/LP.thy Sat Mar 17 12:52:40 2012 +0100
42.3 @@ -0,0 +1,164 @@
42.4 +(* Title: HOL/Matrix/LP.thy
42.5 + Author: Steven Obua
42.6 +*)
42.7 +
42.8 +theory LP
42.9 +imports Main "~~/src/HOL/Library/Lattice_Algebras"
42.10 +begin
42.11 +
42.12 +lemma le_add_right_mono:
42.13 + assumes
42.14 + "a <= b + (c::'a::ordered_ab_group_add)"
42.15 + "c <= d"
42.16 + shows "a <= b + d"
42.17 + apply (rule_tac order_trans[where y = "b+c"])
42.18 + apply (simp_all add: assms)
42.19 + done
42.20 +
42.21 +lemma linprog_dual_estimate:
42.22 + assumes
42.23 + "A * x \<le> (b::'a::lattice_ring)"
42.24 + "0 \<le> y"
42.25 + "abs (A - A') \<le> \<delta>A"
42.26 + "b \<le> b'"
42.27 + "abs (c - c') \<le> \<delta>c"
42.28 + "abs x \<le> r"
42.29 + shows
42.30 + "c * x \<le> y * b' + (y * \<delta>A + abs (y * A' - c') + \<delta>c) * r"
42.31 +proof -
42.32 + from assms have 1: "y * b <= y * b'" by (simp add: mult_left_mono)
42.33 + from assms have 2: "y * (A * x) <= y * b" by (simp add: mult_left_mono)
42.34 + have 3: "y * (A * x) = c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x" by (simp add: algebra_simps)
42.35 + from 1 2 3 have 4: "c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x <= y * b'" by simp
42.36 + have 5: "c * x <= y * b' + abs((y * (A - A') + (y * A' - c') + (c'-c)) * x)"
42.37 + by (simp only: 4 estimate_by_abs)
42.38 + have 6: "abs((y * (A - A') + (y * A' - c') + (c'-c)) * x) <= abs (y * (A - A') + (y * A' - c') + (c'-c)) * abs x"
42.39 + by (simp add: abs_le_mult)
42.40 + have 7: "(abs (y * (A - A') + (y * A' - c') + (c'-c))) * abs x <= (abs (y * (A-A') + (y*A'-c')) + abs(c'-c)) * abs x"
42.41 + by(rule abs_triangle_ineq [THEN mult_right_mono]) simp
42.42 + have 8: " (abs (y * (A-A') + (y*A'-c')) + abs(c'-c)) * abs x <= (abs (y * (A-A')) + abs (y*A'-c') + abs(c'-c)) * abs x"
42.43 + by (simp add: abs_triangle_ineq mult_right_mono)
42.44 + have 9: "(abs (y * (A-A')) + abs (y*A'-c') + abs(c'-c)) * abs x <= (abs y * abs (A-A') + abs (y*A'-c') + abs (c'-c)) * abs x"
42.45 + by (simp add: abs_le_mult mult_right_mono)
42.46 + have 10: "c'-c = -(c-c')" by (simp add: algebra_simps)
42.47 + have 11: "abs (c'-c) = abs (c-c')"
42.48 + by (subst 10, subst abs_minus_cancel, simp)
42.49 + have 12: "(abs y * abs (A-A') + abs (y*A'-c') + abs (c'-c)) * abs x <= (abs y * abs (A-A') + abs (y*A'-c') + \<delta>c) * abs x"
42.50 + by (simp add: 11 assms mult_right_mono)
42.51 + have 13: "(abs y * abs (A-A') + abs (y*A'-c') + \<delta>c) * abs x <= (abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * abs x"
42.52 + by (simp add: assms mult_right_mono mult_left_mono)
42.53 + have r: "(abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * abs x <= (abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * r"
42.54 + apply (rule mult_left_mono)
42.55 + apply (simp add: assms)
42.56 + apply (rule_tac add_mono[of "0::'a" _ "0", simplified])+
42.57 + apply (rule mult_left_mono[of "0" "\<delta>A", simplified])
42.58 + apply (simp_all)
42.59 + apply (rule order_trans[where y="abs (A-A')"], simp_all add: assms)
42.60 + apply (rule order_trans[where y="abs (c-c')"], simp_all add: assms)
42.61 + done
42.62 + from 6 7 8 9 12 13 r have 14:" abs((y * (A - A') + (y * A' - c') + (c'-c)) * x) <=(abs y * \<delta>A + abs (y*A'-c') + \<delta>c) * r"
42.63 + by (simp)
42.64 + show ?thesis
42.65 + apply (rule le_add_right_mono[of _ _ "abs((y * (A - A') + (y * A' - c') + (c'-c)) * x)"])
42.66 + apply (simp_all only: 5 14[simplified abs_of_nonneg[of y, simplified assms]])
42.67 + done
42.68 +qed
42.69 +
42.70 +lemma le_ge_imp_abs_diff_1:
42.71 + assumes
42.72 + "A1 <= (A::'a::lattice_ring)"
42.73 + "A <= A2"
42.74 + shows "abs (A-A1) <= A2-A1"
42.75 +proof -
42.76 + have "0 <= A - A1"
42.77 + proof -
42.78 + have 1: "A - A1 = A + (- A1)" by simp
42.79 + show ?thesis by (simp only: 1 add_right_mono[of A1 A "-A1", simplified, simplified assms])
42.80 + qed
42.81 + then have "abs (A-A1) = A-A1" by (rule abs_of_nonneg)
42.82 + with assms show "abs (A-A1) <= (A2-A1)" by simp
42.83 +qed
42.84 +
42.85 +lemma mult_le_prts:
42.86 + assumes
42.87 + "a1 <= (a::'a::lattice_ring)"
42.88 + "a <= a2"
42.89 + "b1 <= b"
42.90 + "b <= b2"
42.91 + shows
42.92 + "a * b <= pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
42.93 +proof -
42.94 + have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
42.95 + apply (subst prts[symmetric])+
42.96 + apply simp
42.97 + done
42.98 + then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
42.99 + by (simp add: algebra_simps)
42.100 + moreover have "pprt a * pprt b <= pprt a2 * pprt b2"
42.101 + by (simp_all add: assms mult_mono)
42.102 + moreover have "pprt a * nprt b <= pprt a1 * nprt b2"
42.103 + proof -
42.104 + have "pprt a * nprt b <= pprt a * nprt b2"
42.105 + by (simp add: mult_left_mono assms)
42.106 + moreover have "pprt a * nprt b2 <= pprt a1 * nprt b2"
42.107 + by (simp add: mult_right_mono_neg assms)
42.108 + ultimately show ?thesis
42.109 + by simp
42.110 + qed
42.111 + moreover have "nprt a * pprt b <= nprt a2 * pprt b1"
42.112 + proof -
42.113 + have "nprt a * pprt b <= nprt a2 * pprt b"
42.114 + by (simp add: mult_right_mono assms)
42.115 + moreover have "nprt a2 * pprt b <= nprt a2 * pprt b1"
42.116 + by (simp add: mult_left_mono_neg assms)
42.117 + ultimately show ?thesis
42.118 + by simp
42.119 + qed
42.120 + moreover have "nprt a * nprt b <= nprt a1 * nprt b1"
42.121 + proof -
42.122 + have "nprt a * nprt b <= nprt a * nprt b1"
42.123 + by (simp add: mult_left_mono_neg assms)
42.124 + moreover have "nprt a * nprt b1 <= nprt a1 * nprt b1"
42.125 + by (simp add: mult_right_mono_neg assms)
42.126 + ultimately show ?thesis
42.127 + by simp
42.128 + qed
42.129 + ultimately show ?thesis
42.130 + by - (rule add_mono | simp)+
42.131 +qed
42.132 +
42.133 +lemma mult_le_dual_prts:
42.134 + assumes
42.135 + "A * x \<le> (b::'a::lattice_ring)"
42.136 + "0 \<le> y"
42.137 + "A1 \<le> A"
42.138 + "A \<le> A2"
42.139 + "c1 \<le> c"
42.140 + "c \<le> c2"
42.141 + "r1 \<le> x"
42.142 + "x \<le> r2"
42.143 + shows
42.144 + "c * x \<le> y * b + (let s1 = c1 - y * A2; s2 = c2 - y * A1 in pprt s2 * pprt r2 + pprt s1 * nprt r2 + nprt s2 * pprt r1 + nprt s1 * nprt r1)"
42.145 + (is "_ <= _ + ?C")
42.146 +proof -
42.147 + from assms have "y * (A * x) <= y * b" by (simp add: mult_left_mono)
42.148 + moreover have "y * (A * x) = c * x + (y * A - c) * x" by (simp add: algebra_simps)
42.149 + ultimately have "c * x + (y * A - c) * x <= y * b" by simp
42.150 + then have "c * x <= y * b - (y * A - c) * x" by (simp add: le_diff_eq)
42.151 + then have cx: "c * x <= y * b + (c - y * A) * x" by (simp add: algebra_simps)
42.152 + have s2: "c - y * A <= c2 - y * A1"
42.153 + by (simp add: diff_minus assms add_mono mult_left_mono)
42.154 + have s1: "c1 - y * A2 <= c - y * A"
42.155 + by (simp add: diff_minus assms add_mono mult_left_mono)
42.156 + have prts: "(c - y * A) * x <= ?C"
42.157 + apply (simp add: Let_def)
42.158 + apply (rule mult_le_prts)
42.159 + apply (simp_all add: assms s1 s2)
42.160 + done
42.161 + then have "y * b + (c - y * A) * x <= y * b + ?C"
42.162 + by simp
42.163 + with cx show ?thesis
42.164 + by(simp only:)
42.165 +qed
42.166 +
42.167 +end
42.168 \ No newline at end of file
43.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
43.2 +++ b/src/HOL/Matrix_LP/Matrix.thy Sat Mar 17 12:52:40 2012 +0100
43.3 @@ -0,0 +1,1836 @@
43.4 +(* Title: HOL/Matrix/Matrix.thy
43.5 + Author: Steven Obua
43.6 +*)
43.7 +
43.8 +theory Matrix
43.9 +imports Main "~~/src/HOL/Library/Lattice_Algebras"
43.10 +begin
43.11 +
43.12 +type_synonym 'a infmatrix = "nat \<Rightarrow> nat \<Rightarrow> 'a"
43.13 +
43.14 +definition nonzero_positions :: "(nat \<Rightarrow> nat \<Rightarrow> 'a::zero) \<Rightarrow> (nat \<times> nat) set" where
43.15 + "nonzero_positions A = {pos. A (fst pos) (snd pos) ~= 0}"
43.16 +
43.17 +definition "matrix = {(f::(nat \<Rightarrow> nat \<Rightarrow> 'a::zero)). finite (nonzero_positions f)}"
43.18 +
43.19 +typedef (open) 'a matrix = "matrix :: (nat \<Rightarrow> nat \<Rightarrow> 'a::zero) set"
43.20 + unfolding matrix_def
43.21 +proof
43.22 + show "(\<lambda>j i. 0) \<in> {(f::(nat \<Rightarrow> nat \<Rightarrow> 'a::zero)). finite (nonzero_positions f)}"
43.23 + by (simp add: nonzero_positions_def)
43.24 +qed
43.25 +
43.26 +declare Rep_matrix_inverse[simp]
43.27 +
43.28 +lemma finite_nonzero_positions : "finite (nonzero_positions (Rep_matrix A))"
43.29 + by (induct A) (simp add: Abs_matrix_inverse matrix_def)
43.30 +
43.31 +definition nrows :: "('a::zero) matrix \<Rightarrow> nat" where
43.32 + "nrows A == if nonzero_positions(Rep_matrix A) = {} then 0 else Suc(Max ((image fst) (nonzero_positions (Rep_matrix A))))"
43.33 +
43.34 +definition ncols :: "('a::zero) matrix \<Rightarrow> nat" where
43.35 + "ncols A == if nonzero_positions(Rep_matrix A) = {} then 0 else Suc(Max ((image snd) (nonzero_positions (Rep_matrix A))))"
43.36 +
43.37 +lemma nrows:
43.38 + assumes hyp: "nrows A \<le> m"
43.39 + shows "(Rep_matrix A m n) = 0"
43.40 +proof cases
43.41 + assume "nonzero_positions(Rep_matrix A) = {}"
43.42 + then show "(Rep_matrix A m n) = 0" by (simp add: nonzero_positions_def)
43.43 +next
43.44 + assume a: "nonzero_positions(Rep_matrix A) \<noteq> {}"
43.45 + let ?S = "fst`(nonzero_positions(Rep_matrix A))"
43.46 + have c: "finite (?S)" by (simp add: finite_nonzero_positions)
43.47 + from hyp have d: "Max (?S) < m" by (simp add: a nrows_def)
43.48 + have "m \<notin> ?S"
43.49 + proof -
43.50 + have "m \<in> ?S \<Longrightarrow> m <= Max(?S)" by (simp add: Max_ge [OF c])
43.51 + moreover from d have "~(m <= Max ?S)" by (simp)
43.52 + ultimately show "m \<notin> ?S" by (auto)
43.53 + qed
43.54 + thus "Rep_matrix A m n = 0" by (simp add: nonzero_positions_def image_Collect)
43.55 +qed
43.56 +
43.57 +definition transpose_infmatrix :: "'a infmatrix \<Rightarrow> 'a infmatrix" where
43.58 + "transpose_infmatrix A j i == A i j"
43.59 +
43.60 +definition transpose_matrix :: "('a::zero) matrix \<Rightarrow> 'a matrix" where
43.61 + "transpose_matrix == Abs_matrix o transpose_infmatrix o Rep_matrix"
43.62 +
43.63 +declare transpose_infmatrix_def[simp]
43.64 +
43.65 +lemma transpose_infmatrix_twice[simp]: "transpose_infmatrix (transpose_infmatrix A) = A"
43.66 +by ((rule ext)+, simp)
43.67 +
43.68 +lemma transpose_infmatrix: "transpose_infmatrix (% j i. P j i) = (% j i. P i j)"
43.69 + apply (rule ext)+
43.70 + by simp
43.71 +
43.72 +lemma transpose_infmatrix_closed[simp]: "Rep_matrix (Abs_matrix (transpose_infmatrix (Rep_matrix x))) = transpose_infmatrix (Rep_matrix x)"
43.73 +apply (rule Abs_matrix_inverse)
43.74 +apply (simp add: matrix_def nonzero_positions_def image_def)
43.75 +proof -
43.76 + let ?A = "{pos. Rep_matrix x (snd pos) (fst pos) \<noteq> 0}"
43.77 + let ?swap = "% pos. (snd pos, fst pos)"
43.78 + let ?B = "{pos. Rep_matrix x (fst pos) (snd pos) \<noteq> 0}"
43.79 + have swap_image: "?swap`?A = ?B"
43.80 + apply (simp add: image_def)
43.81 + apply (rule set_eqI)
43.82 + apply (simp)
43.83 + proof
43.84 + fix y
43.85 + assume hyp: "\<exists>a b. Rep_matrix x b a \<noteq> 0 \<and> y = (b, a)"
43.86 + thus "Rep_matrix x (fst y) (snd y) \<noteq> 0"
43.87 + proof -
43.88 + from hyp obtain a b where "(Rep_matrix x b a \<noteq> 0 & y = (b,a))" by blast
43.89 + then show "Rep_matrix x (fst y) (snd y) \<noteq> 0" by (simp)
43.90 + qed
43.91 + next
43.92 + fix y
43.93 + assume hyp: "Rep_matrix x (fst y) (snd y) \<noteq> 0"
43.94 + show "\<exists> a b. (Rep_matrix x b a \<noteq> 0 & y = (b,a))"
43.95 + by (rule exI[of _ "snd y"], rule exI[of _ "fst y"]) (simp add: hyp)
43.96 + qed
43.97 + then have "finite (?swap`?A)"
43.98 + proof -
43.99 + have "finite (nonzero_positions (Rep_matrix x))" by (simp add: finite_nonzero_positions)
43.100 + then have "finite ?B" by (simp add: nonzero_positions_def)
43.101 + with swap_image show "finite (?swap`?A)" by (simp)
43.102 + qed
43.103 + moreover
43.104 + have "inj_on ?swap ?A" by (simp add: inj_on_def)
43.105 + ultimately show "finite ?A"by (rule finite_imageD[of ?swap ?A])
43.106 +qed
43.107 +
43.108 +lemma infmatrixforward: "(x::'a infmatrix) = y \<Longrightarrow> \<forall> a b. x a b = y a b" by auto
43.109 +
43.110 +lemma transpose_infmatrix_inject: "(transpose_infmatrix A = transpose_infmatrix B) = (A = B)"
43.111 +apply (auto)
43.112 +apply (rule ext)+
43.113 +apply (simp add: transpose_infmatrix)
43.114 +apply (drule infmatrixforward)
43.115 +apply (simp)
43.116 +done
43.117 +
43.118 +lemma transpose_matrix_inject: "(transpose_matrix A = transpose_matrix B) = (A = B)"
43.119 +apply (simp add: transpose_matrix_def)
43.120 +apply (subst Rep_matrix_inject[THEN sym])+
43.121 +apply (simp only: transpose_infmatrix_closed transpose_infmatrix_inject)
43.122 +done
43.123 +
43.124 +lemma transpose_matrix[simp]: "Rep_matrix(transpose_matrix A) j i = Rep_matrix A i j"
43.125 +by (simp add: transpose_matrix_def)
43.126 +
43.127 +lemma transpose_transpose_id[simp]: "transpose_matrix (transpose_matrix A) = A"
43.128 +by (simp add: transpose_matrix_def)
43.129 +
43.130 +lemma nrows_transpose[simp]: "nrows (transpose_matrix A) = ncols A"
43.131 +by (simp add: nrows_def ncols_def nonzero_positions_def transpose_matrix_def image_def)
43.132 +
43.133 +lemma ncols_transpose[simp]: "ncols (transpose_matrix A) = nrows A"
43.134 +by (simp add: nrows_def ncols_def nonzero_positions_def transpose_matrix_def image_def)
43.135 +
43.136 +lemma ncols: "ncols A <= n \<Longrightarrow> Rep_matrix A m n = 0"
43.137 +proof -
43.138 + assume "ncols A <= n"
43.139 + then have "nrows (transpose_matrix A) <= n" by (simp)
43.140 + then have "Rep_matrix (transpose_matrix A) n m = 0" by (rule nrows)
43.141 + thus "Rep_matrix A m n = 0" by (simp add: transpose_matrix_def)
43.142 +qed
43.143 +
43.144 +lemma ncols_le: "(ncols A <= n) = (! j i. n <= i \<longrightarrow> (Rep_matrix A j i) = 0)" (is "_ = ?st")
43.145 +apply (auto)
43.146 +apply (simp add: ncols)
43.147 +proof (simp add: ncols_def, auto)
43.148 + let ?P = "nonzero_positions (Rep_matrix A)"
43.149 + let ?p = "snd`?P"
43.150 + have a:"finite ?p" by (simp add: finite_nonzero_positions)
43.151 + let ?m = "Max ?p"
43.152 + assume "~(Suc (?m) <= n)"
43.153 + then have b:"n <= ?m" by (simp)
43.154 + fix a b
43.155 + assume "(a,b) \<in> ?P"
43.156 + then have "?p \<noteq> {}" by (auto)
43.157 + with a have "?m \<in> ?p" by (simp)
43.158 + moreover have "!x. (x \<in> ?p \<longrightarrow> (? y. (Rep_matrix A y x) \<noteq> 0))" by (simp add: nonzero_positions_def image_def)
43.159 + ultimately have "? y. (Rep_matrix A y ?m) \<noteq> 0" by (simp)
43.160 + moreover assume ?st
43.161 + ultimately show "False" using b by (simp)
43.162 +qed
43.163 +
43.164 +lemma less_ncols: "(n < ncols A) = (? j i. n <= i & (Rep_matrix A j i) \<noteq> 0)"
43.165 +proof -
43.166 + have a: "!! (a::nat) b. (a < b) = (~(b <= a))" by arith
43.167 + show ?thesis by (simp add: a ncols_le)
43.168 +qed
43.169 +
43.170 +lemma le_ncols: "(n <= ncols A) = (\<forall> m. (\<forall> j i. m <= i \<longrightarrow> (Rep_matrix A j i) = 0) \<longrightarrow> n <= m)"
43.171 +apply (auto)
43.172 +apply (subgoal_tac "ncols A <= m")
43.173 +apply (simp)
43.174 +apply (simp add: ncols_le)
43.175 +apply (drule_tac x="ncols A" in spec)
43.176 +by (simp add: ncols)
43.177 +
43.178 +lemma nrows_le: "(nrows A <= n) = (! j i. n <= j \<longrightarrow> (Rep_matrix A j i) = 0)" (is ?s)
43.179 +proof -
43.180 + have "(nrows A <= n) = (ncols (transpose_matrix A) <= n)" by (simp)
43.181 + also have "\<dots> = (! j i. n <= i \<longrightarrow> (Rep_matrix (transpose_matrix A) j i = 0))" by (rule ncols_le)
43.182 + also have "\<dots> = (! j i. n <= i \<longrightarrow> (Rep_matrix A i j) = 0)" by (simp)
43.183 + finally show "(nrows A <= n) = (! j i. n <= j \<longrightarrow> (Rep_matrix A j i) = 0)" by (auto)
43.184 +qed
43.185 +
43.186 +lemma less_nrows: "(m < nrows A) = (? j i. m <= j & (Rep_matrix A j i) \<noteq> 0)"
43.187 +proof -
43.188 + have a: "!! (a::nat) b. (a < b) = (~(b <= a))" by arith
43.189 + show ?thesis by (simp add: a nrows_le)
43.190 +qed
43.191 +
43.192 +lemma le_nrows: "(n <= nrows A) = (\<forall> m. (\<forall> j i. m <= j \<longrightarrow> (Rep_matrix A j i) = 0) \<longrightarrow> n <= m)"
43.193 +apply (auto)
43.194 +apply (subgoal_tac "nrows A <= m")
43.195 +apply (simp)
43.196 +apply (simp add: nrows_le)
43.197 +apply (drule_tac x="nrows A" in spec)
43.198 +by (simp add: nrows)
43.199 +
43.200 +lemma nrows_notzero: "Rep_matrix A m n \<noteq> 0 \<Longrightarrow> m < nrows A"
43.201 +apply (case_tac "nrows A <= m")
43.202 +apply (simp_all add: nrows)
43.203 +done
43.204 +
43.205 +lemma ncols_notzero: "Rep_matrix A m n \<noteq> 0 \<Longrightarrow> n < ncols A"
43.206 +apply (case_tac "ncols A <= n")
43.207 +apply (simp_all add: ncols)
43.208 +done
43.209 +
43.210 +lemma finite_natarray1: "finite {x. x < (n::nat)}"
43.211 +apply (induct n)
43.212 +apply (simp)
43.213 +proof -
43.214 + fix n
43.215 + have "{x. x < Suc n} = insert n {x. x < n}" by (rule set_eqI, simp, arith)
43.216 + moreover assume "finite {x. x < n}"
43.217 + ultimately show "finite {x. x < Suc n}" by (simp)
43.218 +qed
43.219 +
43.220 +lemma finite_natarray2: "finite {pos. (fst pos) < (m::nat) & (snd pos) < (n::nat)}"
43.221 + apply (induct m)
43.222 + apply (simp+)
43.223 + proof -
43.224 + fix m::nat
43.225 + let ?s0 = "{pos. fst pos < m & snd pos < n}"
43.226 + let ?s1 = "{pos. fst pos < (Suc m) & snd pos < n}"
43.227 + let ?sd = "{pos. fst pos = m & snd pos < n}"
43.228 + assume f0: "finite ?s0"
43.229 + have f1: "finite ?sd"
43.230 + proof -
43.231 + let ?f = "% x. (m, x)"
43.232 + have "{pos. fst pos = m & snd pos < n} = ?f ` {x. x < n}" by (rule set_eqI, simp add: image_def, auto)
43.233 + moreover have "finite {x. x < n}" by (simp add: finite_natarray1)
43.234 + ultimately show "finite {pos. fst pos = m & snd pos < n}" by (simp)
43.235 + qed
43.236 + have su: "?s0 \<union> ?sd = ?s1" by (rule set_eqI, simp, arith)
43.237 + from f0 f1 have "finite (?s0 \<union> ?sd)" by (rule finite_UnI)
43.238 + with su show "finite ?s1" by (simp)
43.239 +qed
43.240 +
43.241 +lemma RepAbs_matrix:
43.242 + assumes aem: "? m. ! j i. m <= j \<longrightarrow> x j i = 0" (is ?em) and aen:"? n. ! j i. (n <= i \<longrightarrow> x j i = 0)" (is ?en)
43.243 + shows "(Rep_matrix (Abs_matrix x)) = x"
43.244 +apply (rule Abs_matrix_inverse)
43.245 +apply (simp add: matrix_def nonzero_positions_def)
43.246 +proof -
43.247 + from aem obtain m where a: "! j i. m <= j \<longrightarrow> x j i = 0" by (blast)
43.248 + from aen obtain n where b: "! j i. n <= i \<longrightarrow> x j i = 0" by (blast)
43.249 + let ?u = "{pos. x (fst pos) (snd pos) \<noteq> 0}"
43.250 + let ?v = "{pos. fst pos < m & snd pos < n}"
43.251 + have c: "!! (m::nat) a. ~(m <= a) \<Longrightarrow> a < m" by (arith)
43.252 + from a b have "(?u \<inter> (-?v)) = {}"
43.253 + apply (simp)
43.254 + apply (rule set_eqI)
43.255 + apply (simp)
43.256 + apply auto
43.257 + by (rule c, auto)+
43.258 + then have d: "?u \<subseteq> ?v" by blast
43.259 + moreover have "finite ?v" by (simp add: finite_natarray2)
43.260 + ultimately show "finite ?u" by (rule finite_subset)
43.261 +qed
43.262 +
43.263 +definition apply_infmatrix :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a infmatrix \<Rightarrow> 'b infmatrix" where
43.264 + "apply_infmatrix f == % A. (% j i. f (A j i))"
43.265 +
43.266 +definition apply_matrix :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a::zero) matrix \<Rightarrow> ('b::zero) matrix" where
43.267 + "apply_matrix f == % A. Abs_matrix (apply_infmatrix f (Rep_matrix A))"
43.268 +
43.269 +definition combine_infmatrix :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a infmatrix \<Rightarrow> 'b infmatrix \<Rightarrow> 'c infmatrix" where
43.270 + "combine_infmatrix f == % A B. (% j i. f (A j i) (B j i))"
43.271 +
43.272 +definition combine_matrix :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a::zero) matrix \<Rightarrow> ('b::zero) matrix \<Rightarrow> ('c::zero) matrix" where
43.273 + "combine_matrix f == % A B. Abs_matrix (combine_infmatrix f (Rep_matrix A) (Rep_matrix B))"
43.274 +
43.275 +lemma expand_apply_infmatrix[simp]: "apply_infmatrix f A j i = f (A j i)"
43.276 +by (simp add: apply_infmatrix_def)
43.277 +
43.278 +lemma expand_combine_infmatrix[simp]: "combine_infmatrix f A B j i = f (A j i) (B j i)"
43.279 +by (simp add: combine_infmatrix_def)
43.280 +
43.281 +definition commutative :: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool" where
43.282 +"commutative f == ! x y. f x y = f y x"
43.283 +
43.284 +definition associative :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
43.285 +"associative f == ! x y z. f (f x y) z = f x (f y z)"
43.286 +
43.287 +text{*
43.288 +To reason about associativity and commutativity of operations on matrices,
43.289 +let's take a step back and look at the general situtation: Assume that we have
43.290 +sets $A$ and $B$ with $B \subset A$ and an abstraction $u: A \rightarrow B$. This abstraction has to fulfill $u(b) = b$ for all $b \in B$, but is arbitrary otherwise.
43.291 +Each function $f: A \times A \rightarrow A$ now induces a function $f': B \times B \rightarrow B$ by $f' = u \circ f$.
43.292 +It is obvious that commutativity of $f$ implies commutativity of $f'$: $f' x y = u (f x y) = u (f y x) = f' y x.$
43.293 +*}
43.294 +
43.295 +lemma combine_infmatrix_commute:
43.296 + "commutative f \<Longrightarrow> commutative (combine_infmatrix f)"
43.297 +by (simp add: commutative_def combine_infmatrix_def)
43.298 +
43.299 +lemma combine_matrix_commute:
43.300 +"commutative f \<Longrightarrow> commutative (combine_matrix f)"
43.301 +by (simp add: combine_matrix_def commutative_def combine_infmatrix_def)
43.302 +
43.303 +text{*
43.304 +On the contrary, given an associative function $f$ we cannot expect $f'$ to be associative. A counterexample is given by $A=\ganz$, $B=\{-1, 0, 1\}$,
43.305 +as $f$ we take addition on $\ganz$, which is clearly associative. The abstraction is given by $u(a) = 0$ for $a \notin B$. Then we have
43.306 +\[ f' (f' 1 1) -1 = u(f (u (f 1 1)) -1) = u(f (u 2) -1) = u (f 0 -1) = -1, \]
43.307 +but on the other hand we have
43.308 +\[ f' 1 (f' 1 -1) = u (f 1 (u (f 1 -1))) = u (f 1 0) = 1.\]
43.309 +A way out of this problem is to assume that $f(A\times A)\subset A$ holds, and this is what we are going to do:
43.310 +*}
43.311 +
43.312 +lemma nonzero_positions_combine_infmatrix[simp]: "f 0 0 = 0 \<Longrightarrow> nonzero_positions (combine_infmatrix f A B) \<subseteq> (nonzero_positions A) \<union> (nonzero_positions B)"
43.313 +by (rule subsetI, simp add: nonzero_positions_def combine_infmatrix_def, auto)
43.314 +
43.315 +lemma finite_nonzero_positions_Rep[simp]: "finite (nonzero_positions (Rep_matrix A))"
43.316 +by (insert Rep_matrix [of A], simp add: matrix_def)
43.317 +
43.318 +lemma combine_infmatrix_closed [simp]:
43.319 + "f 0 0 = 0 \<Longrightarrow> Rep_matrix (Abs_matrix (combine_infmatrix f (Rep_matrix A) (Rep_matrix B))) = combine_infmatrix f (Rep_matrix A) (Rep_matrix B)"
43.320 +apply (rule Abs_matrix_inverse)
43.321 +apply (simp add: matrix_def)
43.322 +apply (rule finite_subset[of _ "(nonzero_positions (Rep_matrix A)) \<union> (nonzero_positions (Rep_matrix B))"])
43.323 +by (simp_all)
43.324 +
43.325 +text {* We need the next two lemmas only later, but it is analog to the above one, so we prove them now: *}
43.326 +lemma nonzero_positions_apply_infmatrix[simp]: "f 0 = 0 \<Longrightarrow> nonzero_positions (apply_infmatrix f A) \<subseteq> nonzero_positions A"
43.327 +by (rule subsetI, simp add: nonzero_positions_def apply_infmatrix_def, auto)
43.328 +
43.329 +lemma apply_infmatrix_closed [simp]:
43.330 + "f 0 = 0 \<Longrightarrow> Rep_matrix (Abs_matrix (apply_infmatrix f (Rep_matrix A))) = apply_infmatrix f (Rep_matrix A)"
43.331 +apply (rule Abs_matrix_inverse)
43.332 +apply (simp add: matrix_def)
43.333 +apply (rule finite_subset[of _ "nonzero_positions (Rep_matrix A)"])
43.334 +by (simp_all)
43.335 +
43.336 +lemma combine_infmatrix_assoc[simp]: "f 0 0 = 0 \<Longrightarrow> associative f \<Longrightarrow> associative (combine_infmatrix f)"
43.337 +by (simp add: associative_def combine_infmatrix_def)
43.338 +
43.339 +lemma comb: "f = g \<Longrightarrow> x = y \<Longrightarrow> f x = g y"
43.340 +by (auto)
43.341 +
43.342 +lemma combine_matrix_assoc: "f 0 0 = 0 \<Longrightarrow> associative f \<Longrightarrow> associative (combine_matrix f)"
43.343 +apply (simp(no_asm) add: associative_def combine_matrix_def, auto)
43.344 +apply (rule comb [of Abs_matrix Abs_matrix])
43.345 +by (auto, insert combine_infmatrix_assoc[of f], simp add: associative_def)
43.346 +
43.347 +lemma Rep_apply_matrix[simp]: "f 0 = 0 \<Longrightarrow> Rep_matrix (apply_matrix f A) j i = f (Rep_matrix A j i)"
43.348 +by (simp add: apply_matrix_def)
43.349 +
43.350 +lemma Rep_combine_matrix[simp]: "f 0 0 = 0 \<Longrightarrow> Rep_matrix (combine_matrix f A B) j i = f (Rep_matrix A j i) (Rep_matrix B j i)"
43.351 + by(simp add: combine_matrix_def)
43.352 +
43.353 +lemma combine_nrows_max: "f 0 0 = 0 \<Longrightarrow> nrows (combine_matrix f A B) <= max (nrows A) (nrows B)"
43.354 +by (simp add: nrows_le)
43.355 +
43.356 +lemma combine_ncols_max: "f 0 0 = 0 \<Longrightarrow> ncols (combine_matrix f A B) <= max (ncols A) (ncols B)"
43.357 +by (simp add: ncols_le)
43.358 +
43.359 +lemma combine_nrows: "f 0 0 = 0 \<Longrightarrow> nrows A <= q \<Longrightarrow> nrows B <= q \<Longrightarrow> nrows(combine_matrix f A B) <= q"
43.360 + by (simp add: nrows_le)
43.361 +
43.362 +lemma combine_ncols: "f 0 0 = 0 \<Longrightarrow> ncols A <= q \<Longrightarrow> ncols B <= q \<Longrightarrow> ncols(combine_matrix f A B) <= q"
43.363 + by (simp add: ncols_le)
43.364 +
43.365 +definition zero_r_neutral :: "('a \<Rightarrow> 'b::zero \<Rightarrow> 'a) \<Rightarrow> bool" where
43.366 + "zero_r_neutral f == ! a. f a 0 = a"
43.367 +
43.368 +definition zero_l_neutral :: "('a::zero \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool" where
43.369 + "zero_l_neutral f == ! a. f 0 a = a"
43.370 +
43.371 +definition zero_closed :: "(('a::zero) \<Rightarrow> ('b::zero) \<Rightarrow> ('c::zero)) \<Rightarrow> bool" where
43.372 + "zero_closed f == (!x. f x 0 = 0) & (!y. f 0 y = 0)"
43.373 +
43.374 +primrec foldseq :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
43.375 +where
43.376 + "foldseq f s 0 = s 0"
43.377 +| "foldseq f s (Suc n) = f (s 0) (foldseq f (% k. s(Suc k)) n)"
43.378 +
43.379 +primrec foldseq_transposed :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
43.380 +where
43.381 + "foldseq_transposed f s 0 = s 0"
43.382 +| "foldseq_transposed f s (Suc n) = f (foldseq_transposed f s n) (s (Suc n))"
43.383 +
43.384 +lemma foldseq_assoc : "associative f \<Longrightarrow> foldseq f = foldseq_transposed f"
43.385 +proof -
43.386 + assume a:"associative f"
43.387 + then have sublemma: "!! n. ! N s. N <= n \<longrightarrow> foldseq f s N = foldseq_transposed f s N"
43.388 + proof -
43.389 + fix n
43.390 + show "!N s. N <= n \<longrightarrow> foldseq f s N = foldseq_transposed f s N"
43.391 + proof (induct n)
43.392 + show "!N s. N <= 0 \<longrightarrow> foldseq f s N = foldseq_transposed f s N" by simp
43.393 + next
43.394 + fix n
43.395 + assume b:"! N s. N <= n \<longrightarrow> foldseq f s N = foldseq_transposed f s N"
43.396 + have c:"!!N s. N <= n \<Longrightarrow> foldseq f s N = foldseq_transposed f s N" by (simp add: b)
43.397 + show "! N t. N <= Suc n \<longrightarrow> foldseq f t N = foldseq_transposed f t N"
43.398 + proof (auto)
43.399 + fix N t
43.400 + assume Nsuc: "N <= Suc n"
43.401 + show "foldseq f t N = foldseq_transposed f t N"
43.402 + proof cases
43.403 + assume "N <= n"
43.404 + then show "foldseq f t N = foldseq_transposed f t N" by (simp add: b)
43.405 + next
43.406 + assume "~(N <= n)"
43.407 + with Nsuc have Nsuceq: "N = Suc n" by simp
43.408 + have neqz: "n \<noteq> 0 \<Longrightarrow> ? m. n = Suc m & Suc m <= n" by arith
43.409 + have assocf: "!! x y z. f x (f y z) = f (f x y) z" by (insert a, simp add: associative_def)
43.410 + show "foldseq f t N = foldseq_transposed f t N"
43.411 + apply (simp add: Nsuceq)
43.412 + apply (subst c)
43.413 + apply (simp)
43.414 + apply (case_tac "n = 0")
43.415 + apply (simp)
43.416 + apply (drule neqz)
43.417 + apply (erule exE)
43.418 + apply (simp)
43.419 + apply (subst assocf)
43.420 + proof -
43.421 + fix m
43.422 + assume "n = Suc m & Suc m <= n"
43.423 + then have mless: "Suc m <= n" by arith
43.424 + then have step1: "foldseq_transposed f (% k. t (Suc k)) m = foldseq f (% k. t (Suc k)) m" (is "?T1 = ?T2")
43.425 + apply (subst c)
43.426 + by simp+
43.427 + have step2: "f (t 0) ?T2 = foldseq f t (Suc m)" (is "_ = ?T3") by simp
43.428 + have step3: "?T3 = foldseq_transposed f t (Suc m)" (is "_ = ?T4")
43.429 + apply (subst c)
43.430 + by (simp add: mless)+
43.431 + have step4: "?T4 = f (foldseq_transposed f t m) (t (Suc m))" (is "_=?T5") by simp
43.432 + from step1 step2 step3 step4 show sowhat: "f (f (t 0) ?T1) (t (Suc (Suc m))) = f ?T5 (t (Suc (Suc m)))" by simp
43.433 + qed
43.434 + qed
43.435 + qed
43.436 + qed
43.437 + qed
43.438 + show "foldseq f = foldseq_transposed f" by ((rule ext)+, insert sublemma, auto)
43.439 + qed
43.440 +
43.441 +lemma foldseq_distr: "\<lbrakk>associative f; commutative f\<rbrakk> \<Longrightarrow> foldseq f (% k. f (u k) (v k)) n = f (foldseq f u n) (foldseq f v n)"
43.442 +proof -
43.443 + assume assoc: "associative f"
43.444 + assume comm: "commutative f"
43.445 + from assoc have a:"!! x y z. f (f x y) z = f x (f y z)" by (simp add: associative_def)
43.446 + from comm have b: "!! x y. f x y = f y x" by (simp add: commutative_def)
43.447 + from assoc comm have c: "!! x y z. f x (f y z) = f y (f x z)" by (simp add: commutative_def associative_def)
43.448 + have "!! n. (! u v. foldseq f (%k. f (u k) (v k)) n = f (foldseq f u n) (foldseq f v n))"
43.449 + apply (induct_tac n)
43.450 + apply (simp+, auto)
43.451 + by (simp add: a b c)
43.452 + then show "foldseq f (% k. f (u k) (v k)) n = f (foldseq f u n) (foldseq f v n)" by simp
43.453 +qed
43.454 +
43.455 +theorem "\<lbrakk>associative f; associative g; \<forall>a b c d. g (f a b) (f c d) = f (g a c) (g b d); ? x y. (f x) \<noteq> (f y); ? x y. (g x) \<noteq> (g y); f x x = x; g x x = x\<rbrakk> \<Longrightarrow> f=g | (! y. f y x = y) | (! y. g y x = y)"
43.456 +oops
43.457 +(* Model found
43.458 +
43.459 +Trying to find a model that refutes: \<lbrakk>associative f; associative g;
43.460 + \<forall>a b c d. g (f a b) (f c d) = f (g a c) (g b d); \<exists>x y. f x \<noteq> f y;
43.461 + \<exists>x y. g x \<noteq> g y; f x x = x; g x x = x\<rbrakk>
43.462 +\<Longrightarrow> f = g \<or> (\<forall>y. f y x = y) \<or> (\<forall>y. g y x = y)
43.463 +Searching for a model of size 1, translating term... invoking SAT solver... no model found.
43.464 +Searching for a model of size 2, translating term... invoking SAT solver... no model found.
43.465 +Searching for a model of size 3, translating term... invoking SAT solver...
43.466 +Model found:
43.467 +Size of types: 'a: 3
43.468 +x: a1
43.469 +g: (a0\<mapsto>(a0\<mapsto>a1, a1\<mapsto>a0, a2\<mapsto>a1), a1\<mapsto>(a0\<mapsto>a0, a1\<mapsto>a1, a2\<mapsto>a0), a2\<mapsto>(a0\<mapsto>a1, a1\<mapsto>a0, a2\<mapsto>a1))
43.470 +f: (a0\<mapsto>(a0\<mapsto>a0, a1\<mapsto>a0, a2\<mapsto>a0), a1\<mapsto>(a0\<mapsto>a1, a1\<mapsto>a1, a2\<mapsto>a1), a2\<mapsto>(a0\<mapsto>a0, a1\<mapsto>a0, a2\<mapsto>a0))
43.471 +*)
43.472 +
43.473 +lemma foldseq_zero:
43.474 +assumes fz: "f 0 0 = 0" and sz: "! i. i <= n \<longrightarrow> s i = 0"
43.475 +shows "foldseq f s n = 0"
43.476 +proof -
43.477 + have "!! n. ! s. (! i. i <= n \<longrightarrow> s i = 0) \<longrightarrow> foldseq f s n = 0"
43.478 + apply (induct_tac n)
43.479 + apply (simp)
43.480 + by (simp add: fz)
43.481 + then show "foldseq f s n = 0" by (simp add: sz)
43.482 +qed
43.483 +
43.484 +lemma foldseq_significant_positions:
43.485 + assumes p: "! i. i <= N \<longrightarrow> S i = T i"
43.486 + shows "foldseq f S N = foldseq f T N"
43.487 +proof -
43.488 + have "!! m . ! s t. (! i. i<=m \<longrightarrow> s i = t i) \<longrightarrow> foldseq f s m = foldseq f t m"
43.489 + apply (induct_tac m)
43.490 + apply (simp)
43.491 + apply (simp)
43.492 + apply (auto)
43.493 + proof -
43.494 + fix n
43.495 + fix s::"nat\<Rightarrow>'a"
43.496 + fix t::"nat\<Rightarrow>'a"
43.497 + assume a: "\<forall>s t. (\<forall>i\<le>n. s i = t i) \<longrightarrow> foldseq f s n = foldseq f t n"
43.498 + assume b: "\<forall>i\<le>Suc n. s i = t i"
43.499 + have c:"!! a b. a = b \<Longrightarrow> f (t 0) a = f (t 0) b" by blast
43.500 + have d:"!! s t. (\<forall>i\<le>n. s i = t i) \<Longrightarrow> foldseq f s n = foldseq f t n" by (simp add: a)
43.501 + show "f (t 0) (foldseq f (\<lambda>k. s (Suc k)) n) = f (t 0) (foldseq f (\<lambda>k. t (Suc k)) n)" by (rule c, simp add: d b)
43.502 + qed
43.503 + with p show ?thesis by simp
43.504 +qed
43.505 +
43.506 +lemma foldseq_tail:
43.507 + assumes "M <= N"
43.508 + shows "foldseq f S N = foldseq f (% k. (if k < M then (S k) else (foldseq f (% k. S(k+M)) (N-M)))) M"
43.509 +proof -
43.510 + have suc: "!! a b. \<lbrakk>a <= Suc b; a \<noteq> Suc b\<rbrakk> \<Longrightarrow> a <= b" by arith
43.511 + have a:"!! a b c . a = b \<Longrightarrow> f c a = f c b" by blast
43.512 + have "!! n. ! m s. m <= n \<longrightarrow> foldseq f s n = foldseq f (% k. (if k < m then (s k) else (foldseq f (% k. s(k+m)) (n-m)))) m"
43.513 + apply (induct_tac n)
43.514 + apply (simp)
43.515 + apply (simp)
43.516 + apply (auto)
43.517 + apply (case_tac "m = Suc na")
43.518 + apply (simp)
43.519 + apply (rule a)
43.520 + apply (rule foldseq_significant_positions)
43.521 + apply (auto)
43.522 + apply (drule suc, simp+)
43.523 + proof -
43.524 + fix na m s
43.525 + assume suba:"\<forall>m\<le>na. \<forall>s. foldseq f s na = foldseq f (\<lambda>k. if k < m then s k else foldseq f (\<lambda>k. s (k + m)) (na - m))m"
43.526 + assume subb:"m <= na"
43.527 + from suba have subc:"!! m s. m <= na \<Longrightarrow>foldseq f s na = foldseq f (\<lambda>k. if k < m then s k else foldseq f (\<lambda>k. s (k + m)) (na - m))m" by simp
43.528 + have subd: "foldseq f (\<lambda>k. if k < m then s (Suc k) else foldseq f (\<lambda>k. s (Suc (k + m))) (na - m)) m =
43.529 + foldseq f (% k. s(Suc k)) na"
43.530 + by (rule subc[of m "% k. s(Suc k)", THEN sym], simp add: subb)
43.531 + from subb have sube: "m \<noteq> 0 \<Longrightarrow> ? mm. m = Suc mm & mm <= na" by arith
43.532 + show "f (s 0) (foldseq f (\<lambda>k. if k < m then s (Suc k) else foldseq f (\<lambda>k. s (Suc (k + m))) (na - m)) m) =
43.533 + foldseq f (\<lambda>k. if k < m then s k else foldseq f (\<lambda>k. s (k + m)) (Suc na - m)) m"
43.534 + apply (simp add: subd)
43.535 + apply (cases "m = 0")
43.536 + apply (simp)
43.537 + apply (drule sube)
43.538 + apply (auto)
43.539 + apply (rule a)
43.540 + by (simp add: subc cong del: if_cong)
43.541 + qed
43.542 + then show ?thesis using assms by simp
43.543 +qed
43.544 +
43.545 +lemma foldseq_zerotail:
43.546 + assumes
43.547 + fz: "f 0 0 = 0"
43.548 + and sz: "! i. n <= i \<longrightarrow> s i = 0"
43.549 + and nm: "n <= m"
43.550 + shows
43.551 + "foldseq f s n = foldseq f s m"
43.552 +proof -
43.553 + show "foldseq f s n = foldseq f s m"
43.554 + apply (simp add: foldseq_tail[OF nm, of f s])
43.555 + apply (rule foldseq_significant_positions)
43.556 + apply (auto)
43.557 + apply (subst foldseq_zero)
43.558 + by (simp add: fz sz)+
43.559 +qed
43.560 +
43.561 +lemma foldseq_zerotail2:
43.562 + assumes "! x. f x 0 = x"
43.563 + and "! i. n < i \<longrightarrow> s i = 0"
43.564 + and nm: "n <= m"
43.565 + shows "foldseq f s n = foldseq f s m"
43.566 +proof -
43.567 + have "f 0 0 = 0" by (simp add: assms)
43.568 + have b:"!! m n. n <= m \<Longrightarrow> m \<noteq> n \<Longrightarrow> ? k. m-n = Suc k" by arith
43.569 + have c: "0 <= m" by simp
43.570 + have d: "!! k. k \<noteq> 0 \<Longrightarrow> ? l. k = Suc l" by arith
43.571 + show ?thesis
43.572 + apply (subst foldseq_tail[OF nm])
43.573 + apply (rule foldseq_significant_positions)
43.574 + apply (auto)
43.575 + apply (case_tac "m=n")
43.576 + apply (simp+)
43.577 + apply (drule b[OF nm])
43.578 + apply (auto)
43.579 + apply (case_tac "k=0")
43.580 + apply (simp add: assms)
43.581 + apply (drule d)
43.582 + apply (auto)
43.583 + apply (simp add: assms foldseq_zero)
43.584 + done
43.585 +qed
43.586 +
43.587 +lemma foldseq_zerostart:
43.588 + "! x. f 0 (f 0 x) = f 0 x \<Longrightarrow> ! i. i <= n \<longrightarrow> s i = 0 \<Longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))"
43.589 +proof -
43.590 + assume f00x: "! x. f 0 (f 0 x) = f 0 x"
43.591 + have "! s. (! i. i<=n \<longrightarrow> s i = 0) \<longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))"
43.592 + apply (induct n)
43.593 + apply (simp)
43.594 + apply (rule allI, rule impI)
43.595 + proof -
43.596 + fix n
43.597 + fix s
43.598 + have a:"foldseq f s (Suc (Suc n)) = f (s 0) (foldseq f (% k. s(Suc k)) (Suc n))" by simp
43.599 + assume b: "! s. ((\<forall>i\<le>n. s i = 0) \<longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n)))"
43.600 + from b have c:"!! s. (\<forall>i\<le>n. s i = 0) \<Longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))" by simp
43.601 + assume d: "! i. i <= Suc n \<longrightarrow> s i = 0"
43.602 + show "foldseq f s (Suc (Suc n)) = f 0 (s (Suc (Suc n)))"
43.603 + apply (subst a)
43.604 + apply (subst c)
43.605 + by (simp add: d f00x)+
43.606 + qed
43.607 + then show "! i. i <= n \<longrightarrow> s i = 0 \<Longrightarrow> foldseq f s (Suc n) = f 0 (s (Suc n))" by simp
43.608 +qed
43.609 +
43.610 +lemma foldseq_zerostart2:
43.611 + "! x. f 0 x = x \<Longrightarrow> ! i. i < n \<longrightarrow> s i = 0 \<Longrightarrow> foldseq f s n = s n"
43.612 +proof -
43.613 + assume a:"! i. i<n \<longrightarrow> s i = 0"
43.614 + assume x:"! x. f 0 x = x"
43.615 + from x have f00x: "! x. f 0 (f 0 x) = f 0 x" by blast
43.616 + have b: "!! i l. i < Suc l = (i <= l)" by arith
43.617 + have d: "!! k. k \<noteq> 0 \<Longrightarrow> ? l. k = Suc l" by arith
43.618 + show "foldseq f s n = s n"
43.619 + apply (case_tac "n=0")
43.620 + apply (simp)
43.621 + apply (insert a)
43.622 + apply (drule d)
43.623 + apply (auto)
43.624 + apply (simp add: b)
43.625 + apply (insert f00x)
43.626 + apply (drule foldseq_zerostart)
43.627 + by (simp add: x)+
43.628 +qed
43.629 +
43.630 +lemma foldseq_almostzero:
43.631 + assumes f0x:"! x. f 0 x = x" and fx0: "! x. f x 0 = x" and s0:"! i. i \<noteq> j \<longrightarrow> s i = 0"
43.632 + shows "foldseq f s n = (if (j <= n) then (s j) else 0)"
43.633 +proof -
43.634 + from s0 have a: "! i. i < j \<longrightarrow> s i = 0" by simp
43.635 + from s0 have b: "! i. j < i \<longrightarrow> s i = 0" by simp
43.636 + show ?thesis
43.637 + apply auto
43.638 + apply (subst foldseq_zerotail2[of f, OF fx0, of j, OF b, of n, THEN sym])
43.639 + apply simp
43.640 + apply (subst foldseq_zerostart2)
43.641 + apply (simp add: f0x a)+
43.642 + apply (subst foldseq_zero)
43.643 + by (simp add: s0 f0x)+
43.644 +qed
43.645 +
43.646 +lemma foldseq_distr_unary:
43.647 + assumes "!! a b. g (f a b) = f (g a) (g b)"
43.648 + shows "g(foldseq f s n) = foldseq f (% x. g(s x)) n"
43.649 +proof -
43.650 + have "! s. g(foldseq f s n) = foldseq f (% x. g(s x)) n"
43.651 + apply (induct_tac n)
43.652 + apply (simp)
43.653 + apply (simp)
43.654 + apply (auto)
43.655 + apply (drule_tac x="% k. s (Suc k)" in spec)
43.656 + by (simp add: assms)
43.657 + then show ?thesis by simp
43.658 +qed
43.659 +
43.660 +definition mult_matrix_n :: "nat \<Rightarrow> (('a::zero) \<Rightarrow> ('b::zero) \<Rightarrow> ('c::zero)) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> 'a matrix \<Rightarrow> 'b matrix \<Rightarrow> 'c matrix" where
43.661 + "mult_matrix_n n fmul fadd A B == Abs_matrix(% j i. foldseq fadd (% k. fmul (Rep_matrix A j k) (Rep_matrix B k i)) n)"
43.662 +
43.663 +definition mult_matrix :: "(('a::zero) \<Rightarrow> ('b::zero) \<Rightarrow> ('c::zero)) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> 'a matrix \<Rightarrow> 'b matrix \<Rightarrow> 'c matrix" where
43.664 + "mult_matrix fmul fadd A B == mult_matrix_n (max (ncols A) (nrows B)) fmul fadd A B"
43.665 +
43.666 +lemma mult_matrix_n:
43.667 + assumes "ncols A \<le> n" (is ?An) "nrows B \<le> n" (is ?Bn) "fadd 0 0 = 0" "fmul 0 0 = 0"
43.668 + shows c:"mult_matrix fmul fadd A B = mult_matrix_n n fmul fadd A B"
43.669 +proof -
43.670 + show ?thesis using assms
43.671 + apply (simp add: mult_matrix_def mult_matrix_n_def)
43.672 + apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
43.673 + apply (rule foldseq_zerotail, simp_all add: nrows_le ncols_le assms)
43.674 + done
43.675 +qed
43.676 +
43.677 +lemma mult_matrix_nm:
43.678 + assumes "ncols A <= n" "nrows B <= n" "ncols A <= m" "nrows B <= m" "fadd 0 0 = 0" "fmul 0 0 = 0"
43.679 + shows "mult_matrix_n n fmul fadd A B = mult_matrix_n m fmul fadd A B"
43.680 +proof -
43.681 + from assms have "mult_matrix_n n fmul fadd A B = mult_matrix fmul fadd A B"
43.682 + by (simp add: mult_matrix_n)
43.683 + also from assms have "\<dots> = mult_matrix_n m fmul fadd A B"
43.684 + by (simp add: mult_matrix_n[THEN sym])
43.685 + finally show "mult_matrix_n n fmul fadd A B = mult_matrix_n m fmul fadd A B" by simp
43.686 +qed
43.687 +
43.688 +definition r_distributive :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool" where
43.689 + "r_distributive fmul fadd == ! a u v. fmul a (fadd u v) = fadd (fmul a u) (fmul a v)"
43.690 +
43.691 +definition l_distributive :: "('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
43.692 + "l_distributive fmul fadd == ! a u v. fmul (fadd u v) a = fadd (fmul u a) (fmul v a)"
43.693 +
43.694 +definition distributive :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
43.695 + "distributive fmul fadd == l_distributive fmul fadd & r_distributive fmul fadd"
43.696 +
43.697 +lemma max1: "!! a x y. (a::nat) <= x \<Longrightarrow> a <= max x y" by (arith)
43.698 +lemma max2: "!! b x y. (b::nat) <= y \<Longrightarrow> b <= max x y" by (arith)
43.699 +
43.700 +lemma r_distributive_matrix:
43.701 + assumes
43.702 + "r_distributive fmul fadd"
43.703 + "associative fadd"
43.704 + "commutative fadd"
43.705 + "fadd 0 0 = 0"
43.706 + "! a. fmul a 0 = 0"
43.707 + "! a. fmul 0 a = 0"
43.708 + shows "r_distributive (mult_matrix fmul fadd) (combine_matrix fadd)"
43.709 +proof -
43.710 + from assms show ?thesis
43.711 + apply (simp add: r_distributive_def mult_matrix_def, auto)
43.712 + proof -
43.713 + fix a::"'a matrix"
43.714 + fix u::"'b matrix"
43.715 + fix v::"'b matrix"
43.716 + let ?mx = "max (ncols a) (max (nrows u) (nrows v))"
43.717 + from assms show "mult_matrix_n (max (ncols a) (nrows (combine_matrix fadd u v))) fmul fadd a (combine_matrix fadd u v) =
43.718 + combine_matrix fadd (mult_matrix_n (max (ncols a) (nrows u)) fmul fadd a u) (mult_matrix_n (max (ncols a) (nrows v)) fmul fadd a v)"
43.719 + apply (subst mult_matrix_nm[of _ _ _ ?mx fadd fmul])
43.720 + apply (simp add: max1 max2 combine_nrows combine_ncols)+
43.721 + apply (subst mult_matrix_nm[of _ _ v ?mx fadd fmul])
43.722 + apply (simp add: max1 max2 combine_nrows combine_ncols)+
43.723 + apply (subst mult_matrix_nm[of _ _ u ?mx fadd fmul])
43.724 + apply (simp add: max1 max2 combine_nrows combine_ncols)+
43.725 + apply (simp add: mult_matrix_n_def r_distributive_def foldseq_distr[of fadd])
43.726 + apply (simp add: combine_matrix_def combine_infmatrix_def)
43.727 + apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
43.728 + apply (simplesubst RepAbs_matrix)
43.729 + apply (simp, auto)
43.730 + apply (rule exI[of _ "nrows a"], simp add: nrows_le foldseq_zero)
43.731 + apply (rule exI[of _ "ncols v"], simp add: ncols_le foldseq_zero)
43.732 + apply (subst RepAbs_matrix)
43.733 + apply (simp, auto)
43.734 + apply (rule exI[of _ "nrows a"], simp add: nrows_le foldseq_zero)
43.735 + apply (rule exI[of _ "ncols u"], simp add: ncols_le foldseq_zero)
43.736 + done
43.737 + qed
43.738 +qed
43.739 +
43.740 +lemma l_distributive_matrix:
43.741 + assumes
43.742 + "l_distributive fmul fadd"
43.743 + "associative fadd"
43.744 + "commutative fadd"
43.745 + "fadd 0 0 = 0"
43.746 + "! a. fmul a 0 = 0"
43.747 + "! a. fmul 0 a = 0"
43.748 + shows "l_distributive (mult_matrix fmul fadd) (combine_matrix fadd)"
43.749 +proof -
43.750 + from assms show ?thesis
43.751 + apply (simp add: l_distributive_def mult_matrix_def, auto)
43.752 + proof -
43.753 + fix a::"'b matrix"
43.754 + fix u::"'a matrix"
43.755 + fix v::"'a matrix"
43.756 + let ?mx = "max (nrows a) (max (ncols u) (ncols v))"
43.757 + from assms show "mult_matrix_n (max (ncols (combine_matrix fadd u v)) (nrows a)) fmul fadd (combine_matrix fadd u v) a =
43.758 + combine_matrix fadd (mult_matrix_n (max (ncols u) (nrows a)) fmul fadd u a) (mult_matrix_n (max (ncols v) (nrows a)) fmul fadd v a)"
43.759 + apply (subst mult_matrix_nm[of v _ _ ?mx fadd fmul])
43.760 + apply (simp add: max1 max2 combine_nrows combine_ncols)+
43.761 + apply (subst mult_matrix_nm[of u _ _ ?mx fadd fmul])
43.762 + apply (simp add: max1 max2 combine_nrows combine_ncols)+
43.763 + apply (subst mult_matrix_nm[of _ _ _ ?mx fadd fmul])
43.764 + apply (simp add: max1 max2 combine_nrows combine_ncols)+
43.765 + apply (simp add: mult_matrix_n_def l_distributive_def foldseq_distr[of fadd])
43.766 + apply (simp add: combine_matrix_def combine_infmatrix_def)
43.767 + apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
43.768 + apply (simplesubst RepAbs_matrix)
43.769 + apply (simp, auto)
43.770 + apply (rule exI[of _ "nrows v"], simp add: nrows_le foldseq_zero)
43.771 + apply (rule exI[of _ "ncols a"], simp add: ncols_le foldseq_zero)
43.772 + apply (subst RepAbs_matrix)
43.773 + apply (simp, auto)
43.774 + apply (rule exI[of _ "nrows u"], simp add: nrows_le foldseq_zero)
43.775 + apply (rule exI[of _ "ncols a"], simp add: ncols_le foldseq_zero)
43.776 + done
43.777 + qed
43.778 +qed
43.779 +
43.780 +instantiation matrix :: (zero) zero
43.781 +begin
43.782 +
43.783 +definition zero_matrix_def: "0 = Abs_matrix (\<lambda>j i. 0)"
43.784 +
43.785 +instance ..
43.786 +
43.787 +end
43.788 +
43.789 +lemma Rep_zero_matrix_def[simp]: "Rep_matrix 0 j i = 0"
43.790 + apply (simp add: zero_matrix_def)
43.791 + apply (subst RepAbs_matrix)
43.792 + by (auto)
43.793 +
43.794 +lemma zero_matrix_def_nrows[simp]: "nrows 0 = 0"
43.795 +proof -
43.796 + have a:"!! (x::nat). x <= 0 \<Longrightarrow> x = 0" by (arith)
43.797 + show "nrows 0 = 0" by (rule a, subst nrows_le, simp)
43.798 +qed
43.799 +
43.800 +lemma zero_matrix_def_ncols[simp]: "ncols 0 = 0"
43.801 +proof -
43.802 + have a:"!! (x::nat). x <= 0 \<Longrightarrow> x = 0" by (arith)
43.803 + show "ncols 0 = 0" by (rule a, subst ncols_le, simp)
43.804 +qed
43.805 +
43.806 +lemma combine_matrix_zero_l_neutral: "zero_l_neutral f \<Longrightarrow> zero_l_neutral (combine_matrix f)"
43.807 + by (simp add: zero_l_neutral_def combine_matrix_def combine_infmatrix_def)
43.808 +
43.809 +lemma combine_matrix_zero_r_neutral: "zero_r_neutral f \<Longrightarrow> zero_r_neutral (combine_matrix f)"
43.810 + by (simp add: zero_r_neutral_def combine_matrix_def combine_infmatrix_def)
43.811 +
43.812 +lemma mult_matrix_zero_closed: "\<lbrakk>fadd 0 0 = 0; zero_closed fmul\<rbrakk> \<Longrightarrow> zero_closed (mult_matrix fmul fadd)"
43.813 + apply (simp add: zero_closed_def mult_matrix_def mult_matrix_n_def)
43.814 + apply (auto)
43.815 + by (subst foldseq_zero, (simp add: zero_matrix_def)+)+
43.816 +
43.817 +lemma mult_matrix_n_zero_right[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul a 0 = 0\<rbrakk> \<Longrightarrow> mult_matrix_n n fmul fadd A 0 = 0"
43.818 + apply (simp add: mult_matrix_n_def)
43.819 + apply (subst foldseq_zero)
43.820 + by (simp_all add: zero_matrix_def)
43.821 +
43.822 +lemma mult_matrix_n_zero_left[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul 0 a = 0\<rbrakk> \<Longrightarrow> mult_matrix_n n fmul fadd 0 A = 0"
43.823 + apply (simp add: mult_matrix_n_def)
43.824 + apply (subst foldseq_zero)
43.825 + by (simp_all add: zero_matrix_def)
43.826 +
43.827 +lemma mult_matrix_zero_left[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul 0 a = 0\<rbrakk> \<Longrightarrow> mult_matrix fmul fadd 0 A = 0"
43.828 +by (simp add: mult_matrix_def)
43.829 +
43.830 +lemma mult_matrix_zero_right[simp]: "\<lbrakk>fadd 0 0 = 0; !a. fmul a 0 = 0\<rbrakk> \<Longrightarrow> mult_matrix fmul fadd A 0 = 0"
43.831 +by (simp add: mult_matrix_def)
43.832 +
43.833 +lemma apply_matrix_zero[simp]: "f 0 = 0 \<Longrightarrow> apply_matrix f 0 = 0"
43.834 + apply (simp add: apply_matrix_def apply_infmatrix_def)
43.835 + by (simp add: zero_matrix_def)
43.836 +
43.837 +lemma combine_matrix_zero: "f 0 0 = 0 \<Longrightarrow> combine_matrix f 0 0 = 0"
43.838 + apply (simp add: combine_matrix_def combine_infmatrix_def)
43.839 + by (simp add: zero_matrix_def)
43.840 +
43.841 +lemma transpose_matrix_zero[simp]: "transpose_matrix 0 = 0"
43.842 +apply (simp add: transpose_matrix_def zero_matrix_def RepAbs_matrix)
43.843 +apply (subst Rep_matrix_inject[symmetric], (rule ext)+)
43.844 +apply (simp add: RepAbs_matrix)
43.845 +done
43.846 +
43.847 +lemma apply_zero_matrix_def[simp]: "apply_matrix (% x. 0) A = 0"
43.848 + apply (simp add: apply_matrix_def apply_infmatrix_def)
43.849 + by (simp add: zero_matrix_def)
43.850 +
43.851 +definition singleton_matrix :: "nat \<Rightarrow> nat \<Rightarrow> ('a::zero) \<Rightarrow> 'a matrix" where
43.852 + "singleton_matrix j i a == Abs_matrix(% m n. if j = m & i = n then a else 0)"
43.853 +
43.854 +definition move_matrix :: "('a::zero) matrix \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a matrix" where
43.855 + "move_matrix A y x == Abs_matrix(% j i. if (((int j)-y) < 0) | (((int i)-x) < 0) then 0 else Rep_matrix A (nat ((int j)-y)) (nat ((int i)-x)))"
43.856 +
43.857 +definition take_rows :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
43.858 + "take_rows A r == Abs_matrix(% j i. if (j < r) then (Rep_matrix A j i) else 0)"
43.859 +
43.860 +definition take_columns :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
43.861 + "take_columns A c == Abs_matrix(% j i. if (i < c) then (Rep_matrix A j i) else 0)"
43.862 +
43.863 +definition column_of_matrix :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
43.864 + "column_of_matrix A n == take_columns (move_matrix A 0 (- int n)) 1"
43.865 +
43.866 +definition row_of_matrix :: "('a::zero) matrix \<Rightarrow> nat \<Rightarrow> 'a matrix" where
43.867 + "row_of_matrix A m == take_rows (move_matrix A (- int m) 0) 1"
43.868 +
43.869 +lemma Rep_singleton_matrix[simp]: "Rep_matrix (singleton_matrix j i e) m n = (if j = m & i = n then e else 0)"
43.870 +apply (simp add: singleton_matrix_def)
43.871 +apply (auto)
43.872 +apply (subst RepAbs_matrix)
43.873 +apply (rule exI[of _ "Suc m"], simp)
43.874 +apply (rule exI[of _ "Suc n"], simp+)
43.875 +by (subst RepAbs_matrix, rule exI[of _ "Suc j"], simp, rule exI[of _ "Suc i"], simp+)+
43.876 +
43.877 +lemma apply_singleton_matrix[simp]: "f 0 = 0 \<Longrightarrow> apply_matrix f (singleton_matrix j i x) = (singleton_matrix j i (f x))"
43.878 +apply (subst Rep_matrix_inject[symmetric])
43.879 +apply (rule ext)+
43.880 +apply (simp)
43.881 +done
43.882 +
43.883 +lemma singleton_matrix_zero[simp]: "singleton_matrix j i 0 = 0"
43.884 + by (simp add: singleton_matrix_def zero_matrix_def)
43.885 +
43.886 +lemma nrows_singleton[simp]: "nrows(singleton_matrix j i e) = (if e = 0 then 0 else Suc j)"
43.887 +proof-
43.888 +have th: "\<not> (\<forall>m. m \<le> j)" "\<exists>n. \<not> n \<le> i" by arith+
43.889 +from th show ?thesis
43.890 +apply (auto)
43.891 +apply (rule le_antisym)
43.892 +apply (subst nrows_le)
43.893 +apply (simp add: singleton_matrix_def, auto)
43.894 +apply (subst RepAbs_matrix)
43.895 +apply auto
43.896 +apply (simp add: Suc_le_eq)
43.897 +apply (rule not_leE)
43.898 +apply (subst nrows_le)
43.899 +by simp
43.900 +qed
43.901 +
43.902 +lemma ncols_singleton[simp]: "ncols(singleton_matrix j i e) = (if e = 0 then 0 else Suc i)"
43.903 +proof-
43.904 +have th: "\<not> (\<forall>m. m \<le> j)" "\<exists>n. \<not> n \<le> i" by arith+
43.905 +from th show ?thesis
43.906 +apply (auto)
43.907 +apply (rule le_antisym)
43.908 +apply (subst ncols_le)
43.909 +apply (simp add: singleton_matrix_def, auto)
43.910 +apply (subst RepAbs_matrix)
43.911 +apply auto
43.912 +apply (simp add: Suc_le_eq)
43.913 +apply (rule not_leE)
43.914 +apply (subst ncols_le)
43.915 +by simp
43.916 +qed
43.917 +
43.918 +lemma combine_singleton: "f 0 0 = 0 \<Longrightarrow> combine_matrix f (singleton_matrix j i a) (singleton_matrix j i b) = singleton_matrix j i (f a b)"
43.919 +apply (simp add: singleton_matrix_def combine_matrix_def combine_infmatrix_def)
43.920 +apply (subst RepAbs_matrix)
43.921 +apply (rule exI[of _ "Suc j"], simp)
43.922 +apply (rule exI[of _ "Suc i"], simp)
43.923 +apply (rule comb[of "Abs_matrix" "Abs_matrix"], simp, (rule ext)+)
43.924 +apply (subst RepAbs_matrix)
43.925 +apply (rule exI[of _ "Suc j"], simp)
43.926 +apply (rule exI[of _ "Suc i"], simp)
43.927 +by simp
43.928 +
43.929 +lemma transpose_singleton[simp]: "transpose_matrix (singleton_matrix j i a) = singleton_matrix i j a"
43.930 +apply (subst Rep_matrix_inject[symmetric], (rule ext)+)
43.931 +apply (simp)
43.932 +done
43.933 +
43.934 +lemma Rep_move_matrix[simp]:
43.935 + "Rep_matrix (move_matrix A y x) j i =
43.936 + (if (((int j)-y) < 0) | (((int i)-x) < 0) then 0 else Rep_matrix A (nat((int j)-y)) (nat((int i)-x)))"
43.937 +apply (simp add: move_matrix_def)
43.938 +apply (auto)
43.939 +by (subst RepAbs_matrix,
43.940 + rule exI[of _ "(nrows A)+(nat (abs y))"], auto, rule nrows, arith,
43.941 + rule exI[of _ "(ncols A)+(nat (abs x))"], auto, rule ncols, arith)+
43.942 +
43.943 +lemma move_matrix_0_0[simp]: "move_matrix A 0 0 = A"
43.944 +by (simp add: move_matrix_def)
43.945 +
43.946 +lemma move_matrix_ortho: "move_matrix A j i = move_matrix (move_matrix A j 0) 0 i"
43.947 +apply (subst Rep_matrix_inject[symmetric])
43.948 +apply (rule ext)+
43.949 +apply (simp)
43.950 +done
43.951 +
43.952 +lemma transpose_move_matrix[simp]:
43.953 + "transpose_matrix (move_matrix A x y) = move_matrix (transpose_matrix A) y x"
43.954 +apply (subst Rep_matrix_inject[symmetric], (rule ext)+)
43.955 +apply (simp)
43.956 +done
43.957 +
43.958 +lemma move_matrix_singleton[simp]: "move_matrix (singleton_matrix u v x) j i =
43.959 + (if (j + int u < 0) | (i + int v < 0) then 0 else (singleton_matrix (nat (j + int u)) (nat (i + int v)) x))"
43.960 + apply (subst Rep_matrix_inject[symmetric])
43.961 + apply (rule ext)+
43.962 + apply (case_tac "j + int u < 0")
43.963 + apply (simp, arith)
43.964 + apply (case_tac "i + int v < 0")
43.965 + apply (simp, arith)
43.966 + apply simp
43.967 + apply arith
43.968 + done
43.969 +
43.970 +lemma Rep_take_columns[simp]:
43.971 + "Rep_matrix (take_columns A c) j i =
43.972 + (if i < c then (Rep_matrix A j i) else 0)"
43.973 +apply (simp add: take_columns_def)
43.974 +apply (simplesubst RepAbs_matrix)
43.975 +apply (rule exI[of _ "nrows A"], auto, simp add: nrows_le)
43.976 +apply (rule exI[of _ "ncols A"], auto, simp add: ncols_le)
43.977 +done
43.978 +
43.979 +lemma Rep_take_rows[simp]:
43.980 + "Rep_matrix (take_rows A r) j i =
43.981 + (if j < r then (Rep_matrix A j i) else 0)"
43.982 +apply (simp add: take_rows_def)
43.983 +apply (simplesubst RepAbs_matrix)
43.984 +apply (rule exI[of _ "nrows A"], auto, simp add: nrows_le)
43.985 +apply (rule exI[of _ "ncols A"], auto, simp add: ncols_le)
43.986 +done
43.987 +
43.988 +lemma Rep_column_of_matrix[simp]:
43.989 + "Rep_matrix (column_of_matrix A c) j i = (if i = 0 then (Rep_matrix A j c) else 0)"
43.990 + by (simp add: column_of_matrix_def)
43.991 +
43.992 +lemma Rep_row_of_matrix[simp]:
43.993 + "Rep_matrix (row_of_matrix A r) j i = (if j = 0 then (Rep_matrix A r i) else 0)"
43.994 + by (simp add: row_of_matrix_def)
43.995 +
43.996 +lemma column_of_matrix: "ncols A <= n \<Longrightarrow> column_of_matrix A n = 0"
43.997 +apply (subst Rep_matrix_inject[THEN sym])
43.998 +apply (rule ext)+
43.999 +by (simp add: ncols)
43.1000 +
43.1001 +lemma row_of_matrix: "nrows A <= n \<Longrightarrow> row_of_matrix A n = 0"
43.1002 +apply (subst Rep_matrix_inject[THEN sym])
43.1003 +apply (rule ext)+
43.1004 +by (simp add: nrows)
43.1005 +
43.1006 +lemma mult_matrix_singleton_right[simp]:
43.1007 + assumes
43.1008 + "! x. fmul x 0 = 0"
43.1009 + "! x. fmul 0 x = 0"
43.1010 + "! x. fadd 0 x = x"
43.1011 + "! x. fadd x 0 = x"
43.1012 + shows "(mult_matrix fmul fadd A (singleton_matrix j i e)) = apply_matrix (% x. fmul x e) (move_matrix (column_of_matrix A j) 0 (int i))"
43.1013 + apply (simp add: mult_matrix_def)
43.1014 + apply (subst mult_matrix_nm[of _ _ _ "max (ncols A) (Suc j)"])
43.1015 + apply (auto)
43.1016 + apply (simp add: assms)+
43.1017 + apply (simp add: mult_matrix_n_def apply_matrix_def apply_infmatrix_def)
43.1018 + apply (rule comb[of "Abs_matrix" "Abs_matrix"], auto, (rule ext)+)
43.1019 + apply (subst foldseq_almostzero[of _ j])
43.1020 + apply (simp add: assms)+
43.1021 + apply (auto)
43.1022 + done
43.1023 +
43.1024 +lemma mult_matrix_ext:
43.1025 + assumes
43.1026 + eprem:
43.1027 + "? e. (! a b. a \<noteq> b \<longrightarrow> fmul a e \<noteq> fmul b e)"
43.1028 + and fprems:
43.1029 + "! a. fmul 0 a = 0"
43.1030 + "! a. fmul a 0 = 0"
43.1031 + "! a. fadd a 0 = a"
43.1032 + "! a. fadd 0 a = a"
43.1033 + and contraprems:
43.1034 + "mult_matrix fmul fadd A = mult_matrix fmul fadd B"
43.1035 + shows
43.1036 + "A = B"
43.1037 +proof(rule contrapos_np[of "False"], simp)
43.1038 + assume a: "A \<noteq> B"
43.1039 + have b: "!! f g. (! x y. f x y = g x y) \<Longrightarrow> f = g" by ((rule ext)+, auto)
43.1040 + have "? j i. (Rep_matrix A j i) \<noteq> (Rep_matrix B j i)"
43.1041 + apply (rule contrapos_np[of "False"], simp+)
43.1042 + apply (insert b[of "Rep_matrix A" "Rep_matrix B"], simp)
43.1043 + by (simp add: Rep_matrix_inject a)
43.1044 + then obtain J I where c:"(Rep_matrix A J I) \<noteq> (Rep_matrix B J I)" by blast
43.1045 + from eprem obtain e where eprops:"(! a b. a \<noteq> b \<longrightarrow> fmul a e \<noteq> fmul b e)" by blast
43.1046 + let ?S = "singleton_matrix I 0 e"
43.1047 + let ?comp = "mult_matrix fmul fadd"
43.1048 + have d: "!!x f g. f = g \<Longrightarrow> f x = g x" by blast
43.1049 + have e: "(% x. fmul x e) 0 = 0" by (simp add: assms)
43.1050 + have "~(?comp A ?S = ?comp B ?S)"
43.1051 + apply (rule notI)
43.1052 + apply (simp add: fprems eprops)
43.1053 + apply (simp add: Rep_matrix_inject[THEN sym])
43.1054 + apply (drule d[of _ _ "J"], drule d[of _ _ "0"])
43.1055 + by (simp add: e c eprops)
43.1056 + with contraprems show "False" by simp
43.1057 +qed
43.1058 +
43.1059 +definition foldmatrix :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a infmatrix) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
43.1060 + "foldmatrix f g A m n == foldseq_transposed g (% j. foldseq f (A j) n) m"
43.1061 +
43.1062 +definition foldmatrix_transposed :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a infmatrix) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
43.1063 + "foldmatrix_transposed f g A m n == foldseq g (% j. foldseq_transposed f (A j) n) m"
43.1064 +
43.1065 +lemma foldmatrix_transpose:
43.1066 + assumes
43.1067 + "! a b c d. g(f a b) (f c d) = f (g a c) (g b d)"
43.1068 + shows
43.1069 + "foldmatrix f g A m n = foldmatrix_transposed g f (transpose_infmatrix A) n m"
43.1070 +proof -
43.1071 + have forall:"!! P x. (! x. P x) \<Longrightarrow> P x" by auto
43.1072 + have tworows:"! A. foldmatrix f g A 1 n = foldmatrix_transposed g f (transpose_infmatrix A) n 1"
43.1073 + apply (induct n)
43.1074 + apply (simp add: foldmatrix_def foldmatrix_transposed_def assms)+
43.1075 + apply (auto)
43.1076 + by (drule_tac x="(% j i. A j (Suc i))" in forall, simp)
43.1077 + show "foldmatrix f g A m n = foldmatrix_transposed g f (transpose_infmatrix A) n m"
43.1078 + apply (simp add: foldmatrix_def foldmatrix_transposed_def)
43.1079 + apply (induct m, simp)
43.1080 + apply (simp)
43.1081 + apply (insert tworows)
43.1082 + apply (drule_tac x="% j i. (if j = 0 then (foldseq_transposed g (\<lambda>u. A u i) m) else (A (Suc m) i))" in spec)
43.1083 + by (simp add: foldmatrix_def foldmatrix_transposed_def)
43.1084 +qed
43.1085 +
43.1086 +lemma foldseq_foldseq:
43.1087 +assumes
43.1088 + "associative f"
43.1089 + "associative g"
43.1090 + "! a b c d. g(f a b) (f c d) = f (g a c) (g b d)"
43.1091 +shows
43.1092 + "foldseq g (% j. foldseq f (A j) n) m = foldseq f (% j. foldseq g ((transpose_infmatrix A) j) m) n"
43.1093 + apply (insert foldmatrix_transpose[of g f A m n])
43.1094 + by (simp add: foldmatrix_def foldmatrix_transposed_def foldseq_assoc[THEN sym] assms)
43.1095 +
43.1096 +lemma mult_n_nrows:
43.1097 +assumes
43.1098 +"! a. fmul 0 a = 0"
43.1099 +"! a. fmul a 0 = 0"
43.1100 +"fadd 0 0 = 0"
43.1101 +shows "nrows (mult_matrix_n n fmul fadd A B) \<le> nrows A"
43.1102 +apply (subst nrows_le)
43.1103 +apply (simp add: mult_matrix_n_def)
43.1104 +apply (subst RepAbs_matrix)
43.1105 +apply (rule_tac x="nrows A" in exI)
43.1106 +apply (simp add: nrows assms foldseq_zero)
43.1107 +apply (rule_tac x="ncols B" in exI)
43.1108 +apply (simp add: ncols assms foldseq_zero)
43.1109 +apply (simp add: nrows assms foldseq_zero)
43.1110 +done
43.1111 +
43.1112 +lemma mult_n_ncols:
43.1113 +assumes
43.1114 +"! a. fmul 0 a = 0"
43.1115 +"! a. fmul a 0 = 0"
43.1116 +"fadd 0 0 = 0"
43.1117 +shows "ncols (mult_matrix_n n fmul fadd A B) \<le> ncols B"
43.1118 +apply (subst ncols_le)
43.1119 +apply (simp add: mult_matrix_n_def)
43.1120 +apply (subst RepAbs_matrix)
43.1121 +apply (rule_tac x="nrows A" in exI)
43.1122 +apply (simp add: nrows assms foldseq_zero)
43.1123 +apply (rule_tac x="ncols B" in exI)
43.1124 +apply (simp add: ncols assms foldseq_zero)
43.1125 +apply (simp add: ncols assms foldseq_zero)
43.1126 +done
43.1127 +
43.1128 +lemma mult_nrows:
43.1129 +assumes
43.1130 +"! a. fmul 0 a = 0"
43.1131 +"! a. fmul a 0 = 0"
43.1132 +"fadd 0 0 = 0"
43.1133 +shows "nrows (mult_matrix fmul fadd A B) \<le> nrows A"
43.1134 +by (simp add: mult_matrix_def mult_n_nrows assms)
43.1135 +
43.1136 +lemma mult_ncols:
43.1137 +assumes
43.1138 +"! a. fmul 0 a = 0"
43.1139 +"! a. fmul a 0 = 0"
43.1140 +"fadd 0 0 = 0"
43.1141 +shows "ncols (mult_matrix fmul fadd A B) \<le> ncols B"
43.1142 +by (simp add: mult_matrix_def mult_n_ncols assms)
43.1143 +
43.1144 +lemma nrows_move_matrix_le: "nrows (move_matrix A j i) <= nat((int (nrows A)) + j)"
43.1145 + apply (auto simp add: nrows_le)
43.1146 + apply (rule nrows)
43.1147 + apply (arith)
43.1148 + done
43.1149 +
43.1150 +lemma ncols_move_matrix_le: "ncols (move_matrix A j i) <= nat((int (ncols A)) + i)"
43.1151 + apply (auto simp add: ncols_le)
43.1152 + apply (rule ncols)
43.1153 + apply (arith)
43.1154 + done
43.1155 +
43.1156 +lemma mult_matrix_assoc:
43.1157 + assumes
43.1158 + "! a. fmul1 0 a = 0"
43.1159 + "! a. fmul1 a 0 = 0"
43.1160 + "! a. fmul2 0 a = 0"
43.1161 + "! a. fmul2 a 0 = 0"
43.1162 + "fadd1 0 0 = 0"
43.1163 + "fadd2 0 0 = 0"
43.1164 + "! a b c d. fadd2 (fadd1 a b) (fadd1 c d) = fadd1 (fadd2 a c) (fadd2 b d)"
43.1165 + "associative fadd1"
43.1166 + "associative fadd2"
43.1167 + "! a b c. fmul2 (fmul1 a b) c = fmul1 a (fmul2 b c)"
43.1168 + "! a b c. fmul2 (fadd1 a b) c = fadd1 (fmul2 a c) (fmul2 b c)"
43.1169 + "! a b c. fmul1 c (fadd2 a b) = fadd2 (fmul1 c a) (fmul1 c b)"
43.1170 + shows "mult_matrix fmul2 fadd2 (mult_matrix fmul1 fadd1 A B) C = mult_matrix fmul1 fadd1 A (mult_matrix fmul2 fadd2 B C)"
43.1171 +proof -
43.1172 + have comb_left: "!! A B x y. A = B \<Longrightarrow> (Rep_matrix (Abs_matrix A)) x y = (Rep_matrix(Abs_matrix B)) x y" by blast
43.1173 + have fmul2fadd1fold: "!! x s n. fmul2 (foldseq fadd1 s n) x = foldseq fadd1 (% k. fmul2 (s k) x) n"
43.1174 + by (rule_tac g1 = "% y. fmul2 y x" in ssubst [OF foldseq_distr_unary], insert assms, simp_all)
43.1175 + have fmul1fadd2fold: "!! x s n. fmul1 x (foldseq fadd2 s n) = foldseq fadd2 (% k. fmul1 x (s k)) n"
43.1176 + using assms by (rule_tac g1 = "% y. fmul1 x y" in ssubst [OF foldseq_distr_unary], simp_all)
43.1177 + let ?N = "max (ncols A) (max (ncols B) (max (nrows B) (nrows C)))"
43.1178 + show ?thesis
43.1179 + apply (simp add: Rep_matrix_inject[THEN sym])
43.1180 + apply (rule ext)+
43.1181 + apply (simp add: mult_matrix_def)
43.1182 + apply (simplesubst mult_matrix_nm[of _ "max (ncols (mult_matrix_n (max (ncols A) (nrows B)) fmul1 fadd1 A B)) (nrows C)" _ "max (ncols B) (nrows C)"])
43.1183 + apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
43.1184 + apply (simplesubst mult_matrix_nm[of _ "max (ncols A) (nrows (mult_matrix_n (max (ncols B) (nrows C)) fmul2 fadd2 B C))" _ "max (ncols A) (nrows B)"])
43.1185 + apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
43.1186 + apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
43.1187 + apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
43.1188 + apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
43.1189 + apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
43.1190 + apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
43.1191 + apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
43.1192 + apply (simplesubst mult_matrix_nm[of _ _ _ "?N"])
43.1193 + apply (simp add: max1 max2 mult_n_ncols mult_n_nrows assms)+
43.1194 + apply (simp add: mult_matrix_n_def)
43.1195 + apply (rule comb_left)
43.1196 + apply ((rule ext)+, simp)
43.1197 + apply (simplesubst RepAbs_matrix)
43.1198 + apply (rule exI[of _ "nrows B"])
43.1199 + apply (simp add: nrows assms foldseq_zero)
43.1200 + apply (rule exI[of _ "ncols C"])
43.1201 + apply (simp add: assms ncols foldseq_zero)
43.1202 + apply (subst RepAbs_matrix)
43.1203 + apply (rule exI[of _ "nrows A"])
43.1204 + apply (simp add: nrows assms foldseq_zero)
43.1205 + apply (rule exI[of _ "ncols B"])
43.1206 + apply (simp add: assms ncols foldseq_zero)
43.1207 + apply (simp add: fmul2fadd1fold fmul1fadd2fold assms)
43.1208 + apply (subst foldseq_foldseq)
43.1209 + apply (simp add: assms)+
43.1210 + apply (simp add: transpose_infmatrix)
43.1211 + done
43.1212 +qed
43.1213 +
43.1214 +lemma
43.1215 + assumes
43.1216 + "! a. fmul1 0 a = 0"
43.1217 + "! a. fmul1 a 0 = 0"
43.1218 + "! a. fmul2 0 a = 0"
43.1219 + "! a. fmul2 a 0 = 0"
43.1220 + "fadd1 0 0 = 0"
43.1221 + "fadd2 0 0 = 0"
43.1222 + "! a b c d. fadd2 (fadd1 a b) (fadd1 c d) = fadd1 (fadd2 a c) (fadd2 b d)"
43.1223 + "associative fadd1"
43.1224 + "associative fadd2"
43.1225 + "! a b c. fmul2 (fmul1 a b) c = fmul1 a (fmul2 b c)"
43.1226 + "! a b c. fmul2 (fadd1 a b) c = fadd1 (fmul2 a c) (fmul2 b c)"
43.1227 + "! a b c. fmul1 c (fadd2 a b) = fadd2 (fmul1 c a) (fmul1 c b)"
43.1228 + shows
43.1229 + "(mult_matrix fmul1 fadd1 A) o (mult_matrix fmul2 fadd2 B) = mult_matrix fmul2 fadd2 (mult_matrix fmul1 fadd1 A B)"
43.1230 +apply (rule ext)+
43.1231 +apply (simp add: comp_def )
43.1232 +apply (simp add: mult_matrix_assoc assms)
43.1233 +done
43.1234 +
43.1235 +lemma mult_matrix_assoc_simple:
43.1236 + assumes
43.1237 + "! a. fmul 0 a = 0"
43.1238 + "! a. fmul a 0 = 0"
43.1239 + "fadd 0 0 = 0"
43.1240 + "associative fadd"
43.1241 + "commutative fadd"
43.1242 + "associative fmul"
43.1243 + "distributive fmul fadd"
43.1244 + shows "mult_matrix fmul fadd (mult_matrix fmul fadd A B) C = mult_matrix fmul fadd A (mult_matrix fmul fadd B C)"
43.1245 +proof -
43.1246 + have "!! a b c d. fadd (fadd a b) (fadd c d) = fadd (fadd a c) (fadd b d)"
43.1247 + using assms by (simp add: associative_def commutative_def)
43.1248 + then show ?thesis
43.1249 + apply (subst mult_matrix_assoc)
43.1250 + using assms
43.1251 + apply simp_all
43.1252 + apply (simp_all add: associative_def distributive_def l_distributive_def r_distributive_def)
43.1253 + done
43.1254 +qed
43.1255 +
43.1256 +lemma transpose_apply_matrix: "f 0 = 0 \<Longrightarrow> transpose_matrix (apply_matrix f A) = apply_matrix f (transpose_matrix A)"
43.1257 +apply (simp add: Rep_matrix_inject[THEN sym])
43.1258 +apply (rule ext)+
43.1259 +by simp
43.1260 +
43.1261 +lemma transpose_combine_matrix: "f 0 0 = 0 \<Longrightarrow> transpose_matrix (combine_matrix f A B) = combine_matrix f (transpose_matrix A) (transpose_matrix B)"
43.1262 +apply (simp add: Rep_matrix_inject[THEN sym])
43.1263 +apply (rule ext)+
43.1264 +by simp
43.1265 +
43.1266 +lemma Rep_mult_matrix:
43.1267 + assumes
43.1268 + "! a. fmul 0 a = 0"
43.1269 + "! a. fmul a 0 = 0"
43.1270 + "fadd 0 0 = 0"
43.1271 + shows
43.1272 + "Rep_matrix(mult_matrix fmul fadd A B) j i =
43.1273 + foldseq fadd (% k. fmul (Rep_matrix A j k) (Rep_matrix B k i)) (max (ncols A) (nrows B))"
43.1274 +apply (simp add: mult_matrix_def mult_matrix_n_def)
43.1275 +apply (subst RepAbs_matrix)
43.1276 +apply (rule exI[of _ "nrows A"], insert assms, simp add: nrows foldseq_zero)
43.1277 +apply (rule exI[of _ "ncols B"], insert assms, simp add: ncols foldseq_zero)
43.1278 +apply simp
43.1279 +done
43.1280 +
43.1281 +lemma transpose_mult_matrix:
43.1282 + assumes
43.1283 + "! a. fmul 0 a = 0"
43.1284 + "! a. fmul a 0 = 0"
43.1285 + "fadd 0 0 = 0"
43.1286 + "! x y. fmul y x = fmul x y"
43.1287 + shows
43.1288 + "transpose_matrix (mult_matrix fmul fadd A B) = mult_matrix fmul fadd (transpose_matrix B) (transpose_matrix A)"
43.1289 + apply (simp add: Rep_matrix_inject[THEN sym])
43.1290 + apply (rule ext)+
43.1291 + using assms
43.1292 + apply (simp add: Rep_mult_matrix max_ac)
43.1293 + done
43.1294 +
43.1295 +lemma column_transpose_matrix: "column_of_matrix (transpose_matrix A) n = transpose_matrix (row_of_matrix A n)"
43.1296 +apply (simp add: Rep_matrix_inject[THEN sym])
43.1297 +apply (rule ext)+
43.1298 +by simp
43.1299 +
43.1300 +lemma take_columns_transpose_matrix: "take_columns (transpose_matrix A) n = transpose_matrix (take_rows A n)"
43.1301 +apply (simp add: Rep_matrix_inject[THEN sym])
43.1302 +apply (rule ext)+
43.1303 +by simp
43.1304 +
43.1305 +instantiation matrix :: ("{zero, ord}") ord
43.1306 +begin
43.1307 +
43.1308 +definition
43.1309 + le_matrix_def: "A \<le> B \<longleftrightarrow> (\<forall>j i. Rep_matrix A j i \<le> Rep_matrix B j i)"
43.1310 +
43.1311 +definition
43.1312 + less_def: "A < (B\<Colon>'a matrix) \<longleftrightarrow> A \<le> B \<and> \<not> B \<le> A"
43.1313 +
43.1314 +instance ..
43.1315 +
43.1316 +end
43.1317 +
43.1318 +instance matrix :: ("{zero, order}") order
43.1319 +apply intro_classes
43.1320 +apply (simp_all add: le_matrix_def less_def)
43.1321 +apply (auto)
43.1322 +apply (drule_tac x=j in spec, drule_tac x=j in spec)
43.1323 +apply (drule_tac x=i in spec, drule_tac x=i in spec)
43.1324 +apply (simp)
43.1325 +apply (simp add: Rep_matrix_inject[THEN sym])
43.1326 +apply (rule ext)+
43.1327 +apply (drule_tac x=xa in spec, drule_tac x=xa in spec)
43.1328 +apply (drule_tac x=xb in spec, drule_tac x=xb in spec)
43.1329 +apply simp
43.1330 +done
43.1331 +
43.1332 +lemma le_apply_matrix:
43.1333 + assumes
43.1334 + "f 0 = 0"
43.1335 + "! x y. x <= y \<longrightarrow> f x <= f y"
43.1336 + "(a::('a::{ord, zero}) matrix) <= b"
43.1337 + shows
43.1338 + "apply_matrix f a <= apply_matrix f b"
43.1339 + using assms by (simp add: le_matrix_def)
43.1340 +
43.1341 +lemma le_combine_matrix:
43.1342 + assumes
43.1343 + "f 0 0 = 0"
43.1344 + "! a b c d. a <= b & c <= d \<longrightarrow> f a c <= f b d"
43.1345 + "A <= B"
43.1346 + "C <= D"
43.1347 + shows
43.1348 + "combine_matrix f A C <= combine_matrix f B D"
43.1349 + using assms by (simp add: le_matrix_def)
43.1350 +
43.1351 +lemma le_left_combine_matrix:
43.1352 + assumes
43.1353 + "f 0 0 = 0"
43.1354 + "! a b c. a <= b \<longrightarrow> f c a <= f c b"
43.1355 + "A <= B"
43.1356 + shows
43.1357 + "combine_matrix f C A <= combine_matrix f C B"
43.1358 + using assms by (simp add: le_matrix_def)
43.1359 +
43.1360 +lemma le_right_combine_matrix:
43.1361 + assumes
43.1362 + "f 0 0 = 0"
43.1363 + "! a b c. a <= b \<longrightarrow> f a c <= f b c"
43.1364 + "A <= B"
43.1365 + shows
43.1366 + "combine_matrix f A C <= combine_matrix f B C"
43.1367 + using assms by (simp add: le_matrix_def)
43.1368 +
43.1369 +lemma le_transpose_matrix: "(A <= B) = (transpose_matrix A <= transpose_matrix B)"
43.1370 + by (simp add: le_matrix_def, auto)
43.1371 +
43.1372 +lemma le_foldseq:
43.1373 + assumes
43.1374 + "! a b c d . a <= b & c <= d \<longrightarrow> f a c <= f b d"
43.1375 + "! i. i <= n \<longrightarrow> s i <= t i"
43.1376 + shows
43.1377 + "foldseq f s n <= foldseq f t n"
43.1378 +proof -
43.1379 + have "! s t. (! i. i<=n \<longrightarrow> s i <= t i) \<longrightarrow> foldseq f s n <= foldseq f t n"
43.1380 + by (induct n) (simp_all add: assms)
43.1381 + then show "foldseq f s n <= foldseq f t n" using assms by simp
43.1382 +qed
43.1383 +
43.1384 +lemma le_left_mult:
43.1385 + assumes
43.1386 + "! a b c d. a <= b & c <= d \<longrightarrow> fadd a c <= fadd b d"
43.1387 + "! c a b. 0 <= c & a <= b \<longrightarrow> fmul c a <= fmul c b"
43.1388 + "! a. fmul 0 a = 0"
43.1389 + "! a. fmul a 0 = 0"
43.1390 + "fadd 0 0 = 0"
43.1391 + "0 <= C"
43.1392 + "A <= B"
43.1393 + shows
43.1394 + "mult_matrix fmul fadd C A <= mult_matrix fmul fadd C B"
43.1395 + using assms
43.1396 + apply (simp add: le_matrix_def Rep_mult_matrix)
43.1397 + apply (auto)
43.1398 + apply (simplesubst foldseq_zerotail[of _ _ _ "max (ncols C) (max (nrows A) (nrows B))"], simp_all add: nrows ncols max1 max2)+
43.1399 + apply (rule le_foldseq)
43.1400 + apply (auto)
43.1401 + done
43.1402 +
43.1403 +lemma le_right_mult:
43.1404 + assumes
43.1405 + "! a b c d. a <= b & c <= d \<longrightarrow> fadd a c <= fadd b d"
43.1406 + "! c a b. 0 <= c & a <= b \<longrightarrow> fmul a c <= fmul b c"
43.1407 + "! a. fmul 0 a = 0"
43.1408 + "! a. fmul a 0 = 0"
43.1409 + "fadd 0 0 = 0"
43.1410 + "0 <= C"
43.1411 + "A <= B"
43.1412 + shows
43.1413 + "mult_matrix fmul fadd A C <= mult_matrix fmul fadd B C"
43.1414 + using assms
43.1415 + apply (simp add: le_matrix_def Rep_mult_matrix)
43.1416 + apply (auto)
43.1417 + apply (simplesubst foldseq_zerotail[of _ _ _ "max (nrows C) (max (ncols A) (ncols B))"], simp_all add: nrows ncols max1 max2)+
43.1418 + apply (rule le_foldseq)
43.1419 + apply (auto)
43.1420 + done
43.1421 +
43.1422 +lemma spec2: "! j i. P j i \<Longrightarrow> P j i" by blast
43.1423 +lemma neg_imp: "(\<not> Q \<longrightarrow> \<not> P) \<Longrightarrow> P \<longrightarrow> Q" by blast
43.1424 +
43.1425 +lemma singleton_matrix_le[simp]: "(singleton_matrix j i a <= singleton_matrix j i b) = (a <= (b::_::order))"
43.1426 + by (auto simp add: le_matrix_def)
43.1427 +
43.1428 +lemma singleton_le_zero[simp]: "(singleton_matrix j i x <= 0) = (x <= (0::'a::{order,zero}))"
43.1429 + apply (auto)
43.1430 + apply (simp add: le_matrix_def)
43.1431 + apply (drule_tac j=j and i=i in spec2)
43.1432 + apply (simp)
43.1433 + apply (simp add: le_matrix_def)
43.1434 + done
43.1435 +
43.1436 +lemma singleton_ge_zero[simp]: "(0 <= singleton_matrix j i x) = ((0::'a::{order,zero}) <= x)"
43.1437 + apply (auto)
43.1438 + apply (simp add: le_matrix_def)
43.1439 + apply (drule_tac j=j and i=i in spec2)
43.1440 + apply (simp)
43.1441 + apply (simp add: le_matrix_def)
43.1442 + done
43.1443 +
43.1444 +lemma move_matrix_le_zero[simp]: "0 <= j \<Longrightarrow> 0 <= i \<Longrightarrow> (move_matrix A j i <= 0) = (A <= (0::('a::{order,zero}) matrix))"
43.1445 + apply (auto simp add: le_matrix_def)
43.1446 + apply (drule_tac j="ja+(nat j)" and i="ia+(nat i)" in spec2)
43.1447 + apply (auto)
43.1448 + done
43.1449 +
43.1450 +lemma move_matrix_zero_le[simp]: "0 <= j \<Longrightarrow> 0 <= i \<Longrightarrow> (0 <= move_matrix A j i) = ((0::('a::{order,zero}) matrix) <= A)"
43.1451 + apply (auto simp add: le_matrix_def)
43.1452 + apply (drule_tac j="ja+(nat j)" and i="ia+(nat i)" in spec2)
43.1453 + apply (auto)
43.1454 + done
43.1455 +
43.1456 +lemma move_matrix_le_move_matrix_iff[simp]: "0 <= j \<Longrightarrow> 0 <= i \<Longrightarrow> (move_matrix A j i <= move_matrix B j i) = (A <= (B::('a::{order,zero}) matrix))"
43.1457 + apply (auto simp add: le_matrix_def)
43.1458 + apply (drule_tac j="ja+(nat j)" and i="ia+(nat i)" in spec2)
43.1459 + apply (auto)
43.1460 + done
43.1461 +
43.1462 +instantiation matrix :: ("{lattice, zero}") lattice
43.1463 +begin
43.1464 +
43.1465 +definition "inf = combine_matrix inf"
43.1466 +
43.1467 +definition "sup = combine_matrix sup"
43.1468 +
43.1469 +instance
43.1470 + by default (auto simp add: le_infI le_matrix_def inf_matrix_def sup_matrix_def)
43.1471 +
43.1472 +end
43.1473 +
43.1474 +instantiation matrix :: ("{plus, zero}") plus
43.1475 +begin
43.1476 +
43.1477 +definition
43.1478 + plus_matrix_def: "A + B = combine_matrix (op +) A B"
43.1479 +
43.1480 +instance ..
43.1481 +
43.1482 +end
43.1483 +
43.1484 +instantiation matrix :: ("{uminus, zero}") uminus
43.1485 +begin
43.1486 +
43.1487 +definition
43.1488 + minus_matrix_def: "- A = apply_matrix uminus A"
43.1489 +
43.1490 +instance ..
43.1491 +
43.1492 +end
43.1493 +
43.1494 +instantiation matrix :: ("{minus, zero}") minus
43.1495 +begin
43.1496 +
43.1497 +definition
43.1498 + diff_matrix_def: "A - B = combine_matrix (op -) A B"
43.1499 +
43.1500 +instance ..
43.1501 +
43.1502 +end
43.1503 +
43.1504 +instantiation matrix :: ("{plus, times, zero}") times
43.1505 +begin
43.1506 +
43.1507 +definition
43.1508 + times_matrix_def: "A * B = mult_matrix (op *) (op +) A B"
43.1509 +
43.1510 +instance ..
43.1511 +
43.1512 +end
43.1513 +
43.1514 +instantiation matrix :: ("{lattice, uminus, zero}") abs
43.1515 +begin
43.1516 +
43.1517 +definition
43.1518 + abs_matrix_def: "abs (A \<Colon> 'a matrix) = sup A (- A)"
43.1519 +
43.1520 +instance ..
43.1521 +
43.1522 +end
43.1523 +
43.1524 +instance matrix :: (monoid_add) monoid_add
43.1525 +proof
43.1526 + fix A B C :: "'a matrix"
43.1527 + show "A + B + C = A + (B + C)"
43.1528 + apply (simp add: plus_matrix_def)
43.1529 + apply (rule combine_matrix_assoc[simplified associative_def, THEN spec, THEN spec, THEN spec])
43.1530 + apply (simp_all add: add_assoc)
43.1531 + done
43.1532 + show "0 + A = A"
43.1533 + apply (simp add: plus_matrix_def)
43.1534 + apply (rule combine_matrix_zero_l_neutral[simplified zero_l_neutral_def, THEN spec])
43.1535 + apply (simp)
43.1536 + done
43.1537 + show "A + 0 = A"
43.1538 + apply (simp add: plus_matrix_def)
43.1539 + apply (rule combine_matrix_zero_r_neutral [simplified zero_r_neutral_def, THEN spec])
43.1540 + apply (simp)
43.1541 + done
43.1542 +qed
43.1543 +
43.1544 +instance matrix :: (comm_monoid_add) comm_monoid_add
43.1545 +proof
43.1546 + fix A B :: "'a matrix"
43.1547 + show "A + B = B + A"
43.1548 + apply (simp add: plus_matrix_def)
43.1549 + apply (rule combine_matrix_commute[simplified commutative_def, THEN spec, THEN spec])
43.1550 + apply (simp_all add: add_commute)
43.1551 + done
43.1552 + show "0 + A = A"
43.1553 + apply (simp add: plus_matrix_def)
43.1554 + apply (rule combine_matrix_zero_l_neutral[simplified zero_l_neutral_def, THEN spec])
43.1555 + apply (simp)
43.1556 + done
43.1557 +qed
43.1558 +
43.1559 +instance matrix :: (group_add) group_add
43.1560 +proof
43.1561 + fix A B :: "'a matrix"
43.1562 + show "- A + A = 0"
43.1563 + by (simp add: plus_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
43.1564 + show "A - B = A + - B"
43.1565 + by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject [symmetric] ext diff_minus)
43.1566 +qed
43.1567 +
43.1568 +instance matrix :: (ab_group_add) ab_group_add
43.1569 +proof
43.1570 + fix A B :: "'a matrix"
43.1571 + show "- A + A = 0"
43.1572 + by (simp add: plus_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
43.1573 + show "A - B = A + - B"
43.1574 + by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
43.1575 +qed
43.1576 +
43.1577 +instance matrix :: (ordered_ab_group_add) ordered_ab_group_add
43.1578 +proof
43.1579 + fix A B C :: "'a matrix"
43.1580 + assume "A <= B"
43.1581 + then show "C + A <= C + B"
43.1582 + apply (simp add: plus_matrix_def)
43.1583 + apply (rule le_left_combine_matrix)
43.1584 + apply (simp_all)
43.1585 + done
43.1586 +qed
43.1587 +
43.1588 +instance matrix :: (lattice_ab_group_add) semilattice_inf_ab_group_add ..
43.1589 +instance matrix :: (lattice_ab_group_add) semilattice_sup_ab_group_add ..
43.1590 +
43.1591 +instance matrix :: (semiring_0) semiring_0
43.1592 +proof
43.1593 + fix A B C :: "'a matrix"
43.1594 + show "A * B * C = A * (B * C)"
43.1595 + apply (simp add: times_matrix_def)
43.1596 + apply (rule mult_matrix_assoc)
43.1597 + apply (simp_all add: associative_def algebra_simps)
43.1598 + done
43.1599 + show "(A + B) * C = A * C + B * C"
43.1600 + apply (simp add: times_matrix_def plus_matrix_def)
43.1601 + apply (rule l_distributive_matrix[simplified l_distributive_def, THEN spec, THEN spec, THEN spec])
43.1602 + apply (simp_all add: associative_def commutative_def algebra_simps)
43.1603 + done
43.1604 + show "A * (B + C) = A * B + A * C"
43.1605 + apply (simp add: times_matrix_def plus_matrix_def)
43.1606 + apply (rule r_distributive_matrix[simplified r_distributive_def, THEN spec, THEN spec, THEN spec])
43.1607 + apply (simp_all add: associative_def commutative_def algebra_simps)
43.1608 + done
43.1609 + show "0 * A = 0" by (simp add: times_matrix_def)
43.1610 + show "A * 0 = 0" by (simp add: times_matrix_def)
43.1611 +qed
43.1612 +
43.1613 +instance matrix :: (ring) ring ..
43.1614 +
43.1615 +instance matrix :: (ordered_ring) ordered_ring
43.1616 +proof
43.1617 + fix A B C :: "'a matrix"
43.1618 + assume a: "A \<le> B"
43.1619 + assume b: "0 \<le> C"
43.1620 + from a b show "C * A \<le> C * B"
43.1621 + apply (simp add: times_matrix_def)
43.1622 + apply (rule le_left_mult)
43.1623 + apply (simp_all add: add_mono mult_left_mono)
43.1624 + done
43.1625 + from a b show "A * C \<le> B * C"
43.1626 + apply (simp add: times_matrix_def)
43.1627 + apply (rule le_right_mult)
43.1628 + apply (simp_all add: add_mono mult_right_mono)
43.1629 + done
43.1630 +qed
43.1631 +
43.1632 +instance matrix :: (lattice_ring) lattice_ring
43.1633 +proof
43.1634 + fix A B C :: "('a :: lattice_ring) matrix"
43.1635 + show "abs A = sup A (-A)"
43.1636 + by (simp add: abs_matrix_def)
43.1637 +qed
43.1638 +
43.1639 +lemma Rep_matrix_add[simp]:
43.1640 + "Rep_matrix ((a::('a::monoid_add)matrix)+b) j i = (Rep_matrix a j i) + (Rep_matrix b j i)"
43.1641 + by (simp add: plus_matrix_def)
43.1642 +
43.1643 +lemma Rep_matrix_mult: "Rep_matrix ((a::('a::semiring_0) matrix) * b) j i =
43.1644 + foldseq (op +) (% k. (Rep_matrix a j k) * (Rep_matrix b k i)) (max (ncols a) (nrows b))"
43.1645 +apply (simp add: times_matrix_def)
43.1646 +apply (simp add: Rep_mult_matrix)
43.1647 +done
43.1648 +
43.1649 +lemma apply_matrix_add: "! x y. f (x+y) = (f x) + (f y) \<Longrightarrow> f 0 = (0::'a)
43.1650 + \<Longrightarrow> apply_matrix f ((a::('a::monoid_add) matrix) + b) = (apply_matrix f a) + (apply_matrix f b)"
43.1651 +apply (subst Rep_matrix_inject[symmetric])
43.1652 +apply (rule ext)+
43.1653 +apply (simp)
43.1654 +done
43.1655 +
43.1656 +lemma singleton_matrix_add: "singleton_matrix j i ((a::_::monoid_add)+b) = (singleton_matrix j i a) + (singleton_matrix j i b)"
43.1657 +apply (subst Rep_matrix_inject[symmetric])
43.1658 +apply (rule ext)+
43.1659 +apply (simp)
43.1660 +done
43.1661 +
43.1662 +lemma nrows_mult: "nrows ((A::('a::semiring_0) matrix) * B) <= nrows A"
43.1663 +by (simp add: times_matrix_def mult_nrows)
43.1664 +
43.1665 +lemma ncols_mult: "ncols ((A::('a::semiring_0) matrix) * B) <= ncols B"
43.1666 +by (simp add: times_matrix_def mult_ncols)
43.1667 +
43.1668 +definition
43.1669 + one_matrix :: "nat \<Rightarrow> ('a::{zero,one}) matrix" where
43.1670 + "one_matrix n = Abs_matrix (% j i. if j = i & j < n then 1 else 0)"
43.1671 +
43.1672 +lemma Rep_one_matrix[simp]: "Rep_matrix (one_matrix n) j i = (if (j = i & j < n) then 1 else 0)"
43.1673 +apply (simp add: one_matrix_def)
43.1674 +apply (simplesubst RepAbs_matrix)
43.1675 +apply (rule exI[of _ n], simp add: split_if)+
43.1676 +by (simp add: split_if)
43.1677 +
43.1678 +lemma nrows_one_matrix[simp]: "nrows ((one_matrix n) :: ('a::zero_neq_one)matrix) = n" (is "?r = _")
43.1679 +proof -
43.1680 + have "?r <= n" by (simp add: nrows_le)
43.1681 + moreover have "n <= ?r" by (simp add:le_nrows, arith)
43.1682 + ultimately show "?r = n" by simp
43.1683 +qed
43.1684 +
43.1685 +lemma ncols_one_matrix[simp]: "ncols ((one_matrix n) :: ('a::zero_neq_one)matrix) = n" (is "?r = _")
43.1686 +proof -
43.1687 + have "?r <= n" by (simp add: ncols_le)
43.1688 + moreover have "n <= ?r" by (simp add: le_ncols, arith)
43.1689 + ultimately show "?r = n" by simp
43.1690 +qed
43.1691 +
43.1692 +lemma one_matrix_mult_right[simp]: "ncols A <= n \<Longrightarrow> (A::('a::{semiring_1}) matrix) * (one_matrix n) = A"
43.1693 +apply (subst Rep_matrix_inject[THEN sym])
43.1694 +apply (rule ext)+
43.1695 +apply (simp add: times_matrix_def Rep_mult_matrix)
43.1696 +apply (rule_tac j1="xa" in ssubst[OF foldseq_almostzero])
43.1697 +apply (simp_all)
43.1698 +by (simp add: ncols)
43.1699 +
43.1700 +lemma one_matrix_mult_left[simp]: "nrows A <= n \<Longrightarrow> (one_matrix n) * A = (A::('a::semiring_1) matrix)"
43.1701 +apply (subst Rep_matrix_inject[THEN sym])
43.1702 +apply (rule ext)+
43.1703 +apply (simp add: times_matrix_def Rep_mult_matrix)
43.1704 +apply (rule_tac j1="x" in ssubst[OF foldseq_almostzero])
43.1705 +apply (simp_all)
43.1706 +by (simp add: nrows)
43.1707 +
43.1708 +lemma transpose_matrix_mult: "transpose_matrix ((A::('a::comm_ring) matrix)*B) = (transpose_matrix B) * (transpose_matrix A)"
43.1709 +apply (simp add: times_matrix_def)
43.1710 +apply (subst transpose_mult_matrix)
43.1711 +apply (simp_all add: mult_commute)
43.1712 +done
43.1713 +
43.1714 +lemma transpose_matrix_add: "transpose_matrix ((A::('a::monoid_add) matrix)+B) = transpose_matrix A + transpose_matrix B"
43.1715 +by (simp add: plus_matrix_def transpose_combine_matrix)
43.1716 +
43.1717 +lemma transpose_matrix_diff: "transpose_matrix ((A::('a::group_add) matrix)-B) = transpose_matrix A - transpose_matrix B"
43.1718 +by (simp add: diff_matrix_def transpose_combine_matrix)
43.1719 +
43.1720 +lemma transpose_matrix_minus: "transpose_matrix (-(A::('a::group_add) matrix)) = - transpose_matrix (A::'a matrix)"
43.1721 +by (simp add: minus_matrix_def transpose_apply_matrix)
43.1722 +
43.1723 +definition right_inverse_matrix :: "('a::{ring_1}) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
43.1724 + "right_inverse_matrix A X == (A * X = one_matrix (max (nrows A) (ncols X))) \<and> nrows X \<le> ncols A"
43.1725 +
43.1726 +definition left_inverse_matrix :: "('a::{ring_1}) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
43.1727 + "left_inverse_matrix A X == (X * A = one_matrix (max(nrows X) (ncols A))) \<and> ncols X \<le> nrows A"
43.1728 +
43.1729 +definition inverse_matrix :: "('a::{ring_1}) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
43.1730 + "inverse_matrix A X == (right_inverse_matrix A X) \<and> (left_inverse_matrix A X)"
43.1731 +
43.1732 +lemma right_inverse_matrix_dim: "right_inverse_matrix A X \<Longrightarrow> nrows A = ncols X"
43.1733 +apply (insert ncols_mult[of A X], insert nrows_mult[of A X])
43.1734 +by (simp add: right_inverse_matrix_def)
43.1735 +
43.1736 +lemma left_inverse_matrix_dim: "left_inverse_matrix A Y \<Longrightarrow> ncols A = nrows Y"
43.1737 +apply (insert ncols_mult[of Y A], insert nrows_mult[of Y A])
43.1738 +by (simp add: left_inverse_matrix_def)
43.1739 +
43.1740 +lemma left_right_inverse_matrix_unique:
43.1741 + assumes "left_inverse_matrix A Y" "right_inverse_matrix A X"
43.1742 + shows "X = Y"
43.1743 +proof -
43.1744 + have "Y = Y * one_matrix (nrows A)"
43.1745 + apply (subst one_matrix_mult_right)
43.1746 + using assms
43.1747 + apply (simp_all add: left_inverse_matrix_def)
43.1748 + done
43.1749 + also have "\<dots> = Y * (A * X)"
43.1750 + apply (insert assms)
43.1751 + apply (frule right_inverse_matrix_dim)
43.1752 + by (simp add: right_inverse_matrix_def)
43.1753 + also have "\<dots> = (Y * A) * X" by (simp add: mult_assoc)
43.1754 + also have "\<dots> = X"
43.1755 + apply (insert assms)
43.1756 + apply (frule left_inverse_matrix_dim)
43.1757 + apply (simp_all add: left_inverse_matrix_def right_inverse_matrix_def one_matrix_mult_left)
43.1758 + done
43.1759 + ultimately show "X = Y" by (simp)
43.1760 +qed
43.1761 +
43.1762 +lemma inverse_matrix_inject: "\<lbrakk> inverse_matrix A X; inverse_matrix A Y \<rbrakk> \<Longrightarrow> X = Y"
43.1763 + by (auto simp add: inverse_matrix_def left_right_inverse_matrix_unique)
43.1764 +
43.1765 +lemma one_matrix_inverse: "inverse_matrix (one_matrix n) (one_matrix n)"
43.1766 + by (simp add: inverse_matrix_def left_inverse_matrix_def right_inverse_matrix_def)
43.1767 +
43.1768 +lemma zero_imp_mult_zero: "(a::'a::semiring_0) = 0 | b = 0 \<Longrightarrow> a * b = 0"
43.1769 +by auto
43.1770 +
43.1771 +lemma Rep_matrix_zero_imp_mult_zero:
43.1772 + "! j i k. (Rep_matrix A j k = 0) | (Rep_matrix B k i) = 0 \<Longrightarrow> A * B = (0::('a::lattice_ring) matrix)"
43.1773 +apply (subst Rep_matrix_inject[symmetric])
43.1774 +apply (rule ext)+
43.1775 +apply (auto simp add: Rep_matrix_mult foldseq_zero zero_imp_mult_zero)
43.1776 +done
43.1777 +
43.1778 +lemma add_nrows: "nrows (A::('a::monoid_add) matrix) <= u \<Longrightarrow> nrows B <= u \<Longrightarrow> nrows (A + B) <= u"
43.1779 +apply (simp add: plus_matrix_def)
43.1780 +apply (rule combine_nrows)
43.1781 +apply (simp_all)
43.1782 +done
43.1783 +
43.1784 +lemma move_matrix_row_mult: "move_matrix ((A::('a::semiring_0) matrix) * B) j 0 = (move_matrix A j 0) * B"
43.1785 +apply (subst Rep_matrix_inject[symmetric])
43.1786 +apply (rule ext)+
43.1787 +apply (auto simp add: Rep_matrix_mult foldseq_zero)
43.1788 +apply (rule_tac foldseq_zerotail[symmetric])
43.1789 +apply (auto simp add: nrows zero_imp_mult_zero max2)
43.1790 +apply (rule order_trans)
43.1791 +apply (rule ncols_move_matrix_le)
43.1792 +apply (simp add: max1)
43.1793 +done
43.1794 +
43.1795 +lemma move_matrix_col_mult: "move_matrix ((A::('a::semiring_0) matrix) * B) 0 i = A * (move_matrix B 0 i)"
43.1796 +apply (subst Rep_matrix_inject[symmetric])
43.1797 +apply (rule ext)+
43.1798 +apply (auto simp add: Rep_matrix_mult foldseq_zero)
43.1799 +apply (rule_tac foldseq_zerotail[symmetric])
43.1800 +apply (auto simp add: ncols zero_imp_mult_zero max1)
43.1801 +apply (rule order_trans)
43.1802 +apply (rule nrows_move_matrix_le)
43.1803 +apply (simp add: max2)
43.1804 +done
43.1805 +
43.1806 +lemma move_matrix_add: "((move_matrix (A + B) j i)::(('a::monoid_add) matrix)) = (move_matrix A j i) + (move_matrix B j i)"
43.1807 +apply (subst Rep_matrix_inject[symmetric])
43.1808 +apply (rule ext)+
43.1809 +apply (simp)
43.1810 +done
43.1811 +
43.1812 +lemma move_matrix_mult: "move_matrix ((A::('a::semiring_0) matrix)*B) j i = (move_matrix A j 0) * (move_matrix B 0 i)"
43.1813 +by (simp add: move_matrix_ortho[of "A*B"] move_matrix_col_mult move_matrix_row_mult)
43.1814 +
43.1815 +definition scalar_mult :: "('a::ring) \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" where
43.1816 + "scalar_mult a m == apply_matrix (op * a) m"
43.1817 +
43.1818 +lemma scalar_mult_zero[simp]: "scalar_mult y 0 = 0"
43.1819 +by (simp add: scalar_mult_def)
43.1820 +
43.1821 +lemma scalar_mult_add: "scalar_mult y (a+b) = (scalar_mult y a) + (scalar_mult y b)"
43.1822 +by (simp add: scalar_mult_def apply_matrix_add algebra_simps)
43.1823 +
43.1824 +lemma Rep_scalar_mult[simp]: "Rep_matrix (scalar_mult y a) j i = y * (Rep_matrix a j i)"
43.1825 +by (simp add: scalar_mult_def)
43.1826 +
43.1827 +lemma scalar_mult_singleton[simp]: "scalar_mult y (singleton_matrix j i x) = singleton_matrix j i (y * x)"
43.1828 +apply (subst Rep_matrix_inject[symmetric])
43.1829 +apply (rule ext)+
43.1830 +apply (auto)
43.1831 +done
43.1832 +
43.1833 +lemma Rep_minus[simp]: "Rep_matrix (-(A::_::group_add)) x y = - (Rep_matrix A x y)"
43.1834 +by (simp add: minus_matrix_def)
43.1835 +
43.1836 +lemma Rep_abs[simp]: "Rep_matrix (abs (A::_::lattice_ab_group_add)) x y = abs (Rep_matrix A x y)"
43.1837 +by (simp add: abs_lattice sup_matrix_def)
43.1838 +
43.1839 +end
44.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
44.2 +++ b/src/HOL/Matrix_LP/ROOT.ML Sat Mar 17 12:52:40 2012 +0100
44.3 @@ -0,0 +1,2 @@
44.4 +
44.5 +use_thy "Cplex";
45.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
45.2 +++ b/src/HOL/Matrix_LP/SparseMatrix.thy Sat Mar 17 12:52:40 2012 +0100
45.3 @@ -0,0 +1,1070 @@
45.4 +(* Title: HOL/Matrix/SparseMatrix.thy
45.5 + Author: Steven Obua
45.6 +*)
45.7 +
45.8 +theory SparseMatrix
45.9 +imports Matrix
45.10 +begin
45.11 +
45.12 +type_synonym 'a spvec = "(nat * 'a) list"
45.13 +type_synonym 'a spmat = "'a spvec spvec"
45.14 +
45.15 +definition sparse_row_vector :: "('a::ab_group_add) spvec \<Rightarrow> 'a matrix"
45.16 + where "sparse_row_vector arr = foldl (% m x. m + (singleton_matrix 0 (fst x) (snd x))) 0 arr"
45.17 +
45.18 +definition sparse_row_matrix :: "('a::ab_group_add) spmat \<Rightarrow> 'a matrix"
45.19 + where "sparse_row_matrix arr = foldl (% m r. m + (move_matrix (sparse_row_vector (snd r)) (int (fst r)) 0)) 0 arr"
45.20 +
45.21 +code_datatype sparse_row_vector sparse_row_matrix
45.22 +
45.23 +lemma sparse_row_vector_empty [simp]: "sparse_row_vector [] = 0"
45.24 + by (simp add: sparse_row_vector_def)
45.25 +
45.26 +lemma sparse_row_matrix_empty [simp]: "sparse_row_matrix [] = 0"
45.27 + by (simp add: sparse_row_matrix_def)
45.28 +
45.29 +lemmas [code] = sparse_row_vector_empty [symmetric]
45.30 +
45.31 +lemma foldl_distrstart: "! a x y. (f (g x y) a = g x (f y a)) \<Longrightarrow> (foldl f (g x y) l = g x (foldl f y l))"
45.32 + by (induct l arbitrary: x y, auto)
45.33 +
45.34 +lemma sparse_row_vector_cons[simp]:
45.35 + "sparse_row_vector (a # arr) = (singleton_matrix 0 (fst a) (snd a)) + (sparse_row_vector arr)"
45.36 + apply (induct arr)
45.37 + apply (auto simp add: sparse_row_vector_def)
45.38 + apply (simp add: foldl_distrstart [of "\<lambda>m x. m + singleton_matrix 0 (fst x) (snd x)" "\<lambda>x m. singleton_matrix 0 (fst x) (snd x) + m"])
45.39 + done
45.40 +
45.41 +lemma sparse_row_vector_append[simp]:
45.42 + "sparse_row_vector (a @ b) = (sparse_row_vector a) + (sparse_row_vector b)"
45.43 + by (induct a) auto
45.44 +
45.45 +lemma nrows_spvec[simp]: "nrows (sparse_row_vector x) <= (Suc 0)"
45.46 + apply (induct x)
45.47 + apply (simp_all add: add_nrows)
45.48 + done
45.49 +
45.50 +lemma sparse_row_matrix_cons: "sparse_row_matrix (a#arr) = ((move_matrix (sparse_row_vector (snd a)) (int (fst a)) 0)) + sparse_row_matrix arr"
45.51 + apply (induct arr)
45.52 + apply (auto simp add: sparse_row_matrix_def)
45.53 + apply (simp add: foldl_distrstart[of "\<lambda>m x. m + (move_matrix (sparse_row_vector (snd x)) (int (fst x)) 0)"
45.54 + "% a m. (move_matrix (sparse_row_vector (snd a)) (int (fst a)) 0) + m"])
45.55 + done
45.56 +
45.57 +lemma sparse_row_matrix_append: "sparse_row_matrix (arr@brr) = (sparse_row_matrix arr) + (sparse_row_matrix brr)"
45.58 + apply (induct arr)
45.59 + apply (auto simp add: sparse_row_matrix_cons)
45.60 + done
45.61 +
45.62 +primrec sorted_spvec :: "'a spvec \<Rightarrow> bool"
45.63 +where
45.64 + "sorted_spvec [] = True"
45.65 +| sorted_spvec_step: "sorted_spvec (a#as) = (case as of [] \<Rightarrow> True | b#bs \<Rightarrow> ((fst a < fst b) & (sorted_spvec as)))"
45.66 +
45.67 +primrec sorted_spmat :: "'a spmat \<Rightarrow> bool"
45.68 +where
45.69 + "sorted_spmat [] = True"
45.70 +| "sorted_spmat (a#as) = ((sorted_spvec (snd a)) & (sorted_spmat as))"
45.71 +
45.72 +declare sorted_spvec.simps [simp del]
45.73 +
45.74 +lemma sorted_spvec_empty[simp]: "sorted_spvec [] = True"
45.75 +by (simp add: sorted_spvec.simps)
45.76 +
45.77 +lemma sorted_spvec_cons1: "sorted_spvec (a#as) \<Longrightarrow> sorted_spvec as"
45.78 +apply (induct as)
45.79 +apply (auto simp add: sorted_spvec.simps)
45.80 +done
45.81 +
45.82 +lemma sorted_spvec_cons2: "sorted_spvec (a#b#t) \<Longrightarrow> sorted_spvec (a#t)"
45.83 +apply (induct t)
45.84 +apply (auto simp add: sorted_spvec.simps)
45.85 +done
45.86 +
45.87 +lemma sorted_spvec_cons3: "sorted_spvec(a#b#t) \<Longrightarrow> fst a < fst b"
45.88 +apply (auto simp add: sorted_spvec.simps)
45.89 +done
45.90 +
45.91 +lemma sorted_sparse_row_vector_zero[rule_format]: "m <= n \<Longrightarrow> sorted_spvec ((n,a)#arr) \<longrightarrow> Rep_matrix (sparse_row_vector arr) j m = 0"
45.92 +apply (induct arr)
45.93 +apply (auto)
45.94 +apply (frule sorted_spvec_cons2,simp)+
45.95 +apply (frule sorted_spvec_cons3, simp)
45.96 +done
45.97 +
45.98 +lemma sorted_sparse_row_matrix_zero[rule_format]: "m <= n \<Longrightarrow> sorted_spvec ((n,a)#arr) \<longrightarrow> Rep_matrix (sparse_row_matrix arr) m j = 0"
45.99 + apply (induct arr)
45.100 + apply (auto)
45.101 + apply (frule sorted_spvec_cons2, simp)
45.102 + apply (frule sorted_spvec_cons3, simp)
45.103 + apply (simp add: sparse_row_matrix_cons)
45.104 + done
45.105 +
45.106 +primrec minus_spvec :: "('a::ab_group_add) spvec \<Rightarrow> 'a spvec"
45.107 +where
45.108 + "minus_spvec [] = []"
45.109 +| "minus_spvec (a#as) = (fst a, -(snd a))#(minus_spvec as)"
45.110 +
45.111 +primrec abs_spvec :: "('a::lattice_ab_group_add_abs) spvec \<Rightarrow> 'a spvec"
45.112 +where
45.113 + "abs_spvec [] = []"
45.114 +| "abs_spvec (a#as) = (fst a, abs (snd a))#(abs_spvec as)"
45.115 +
45.116 +lemma sparse_row_vector_minus:
45.117 + "sparse_row_vector (minus_spvec v) = - (sparse_row_vector v)"
45.118 + apply (induct v)
45.119 + apply (simp_all add: sparse_row_vector_cons)
45.120 + apply (simp add: Rep_matrix_inject[symmetric])
45.121 + apply (rule ext)+
45.122 + apply simp
45.123 + done
45.124 +
45.125 +instance matrix :: (lattice_ab_group_add_abs) lattice_ab_group_add_abs
45.126 +apply default
45.127 +unfolding abs_matrix_def .. (*FIXME move*)
45.128 +
45.129 +lemma sparse_row_vector_abs:
45.130 + "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (abs_spvec v) = abs (sparse_row_vector v)"
45.131 + apply (induct v)
45.132 + apply simp_all
45.133 + apply (frule_tac sorted_spvec_cons1, simp)
45.134 + apply (simp only: Rep_matrix_inject[symmetric])
45.135 + apply (rule ext)+
45.136 + apply auto
45.137 + apply (subgoal_tac "Rep_matrix (sparse_row_vector v) 0 a = 0")
45.138 + apply (simp)
45.139 + apply (rule sorted_sparse_row_vector_zero)
45.140 + apply auto
45.141 + done
45.142 +
45.143 +lemma sorted_spvec_minus_spvec:
45.144 + "sorted_spvec v \<Longrightarrow> sorted_spvec (minus_spvec v)"
45.145 + apply (induct v)
45.146 + apply (simp)
45.147 + apply (frule sorted_spvec_cons1, simp)
45.148 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.149 + done
45.150 +
45.151 +lemma sorted_spvec_abs_spvec:
45.152 + "sorted_spvec v \<Longrightarrow> sorted_spvec (abs_spvec v)"
45.153 + apply (induct v)
45.154 + apply (simp)
45.155 + apply (frule sorted_spvec_cons1, simp)
45.156 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.157 + done
45.158 +
45.159 +definition "smult_spvec y = map (% a. (fst a, y * snd a))"
45.160 +
45.161 +lemma smult_spvec_empty[simp]: "smult_spvec y [] = []"
45.162 + by (simp add: smult_spvec_def)
45.163 +
45.164 +lemma smult_spvec_cons: "smult_spvec y (a#arr) = (fst a, y * (snd a)) # (smult_spvec y arr)"
45.165 + by (simp add: smult_spvec_def)
45.166 +
45.167 +fun addmult_spvec :: "('a::ring) \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec"
45.168 +where
45.169 + "addmult_spvec y arr [] = arr"
45.170 +| "addmult_spvec y [] brr = smult_spvec y brr"
45.171 +| "addmult_spvec y ((i,a)#arr) ((j,b)#brr) = (
45.172 + if i < j then ((i,a)#(addmult_spvec y arr ((j,b)#brr)))
45.173 + else (if (j < i) then ((j, y * b)#(addmult_spvec y ((i,a)#arr) brr))
45.174 + else ((i, a + y*b)#(addmult_spvec y arr brr))))"
45.175 +(* Steven used termination "measure (% (y, a, b). length a + (length b))" *)
45.176 +
45.177 +lemma addmult_spvec_empty1[simp]: "addmult_spvec y [] a = smult_spvec y a"
45.178 + by (induct a) auto
45.179 +
45.180 +lemma addmult_spvec_empty2[simp]: "addmult_spvec y a [] = a"
45.181 + by (induct a) auto
45.182 +
45.183 +lemma sparse_row_vector_map: "(! x y. f (x+y) = (f x) + (f y)) \<Longrightarrow> (f::'a\<Rightarrow>('a::lattice_ring)) 0 = 0 \<Longrightarrow>
45.184 + sparse_row_vector (map (% x. (fst x, f (snd x))) a) = apply_matrix f (sparse_row_vector a)"
45.185 + apply (induct a)
45.186 + apply (simp_all add: apply_matrix_add)
45.187 + done
45.188 +
45.189 +lemma sparse_row_vector_smult: "sparse_row_vector (smult_spvec y a) = scalar_mult y (sparse_row_vector a)"
45.190 + apply (induct a)
45.191 + apply (simp_all add: smult_spvec_cons scalar_mult_add)
45.192 + done
45.193 +
45.194 +lemma sparse_row_vector_addmult_spvec: "sparse_row_vector (addmult_spvec (y::'a::lattice_ring) a b) =
45.195 + (sparse_row_vector a) + (scalar_mult y (sparse_row_vector b))"
45.196 + apply (induct y a b rule: addmult_spvec.induct)
45.197 + apply (simp add: scalar_mult_add smult_spvec_cons sparse_row_vector_smult singleton_matrix_add)+
45.198 + done
45.199 +
45.200 +lemma sorted_smult_spvec: "sorted_spvec a \<Longrightarrow> sorted_spvec (smult_spvec y a)"
45.201 + apply (auto simp add: smult_spvec_def)
45.202 + apply (induct a)
45.203 + apply (auto simp add: sorted_spvec.simps split:list.split_asm)
45.204 + done
45.205 +
45.206 +lemma sorted_spvec_addmult_spvec_helper: "\<lbrakk>sorted_spvec (addmult_spvec y ((a, b) # arr) brr); aa < a; sorted_spvec ((a, b) # arr);
45.207 + sorted_spvec ((aa, ba) # brr)\<rbrakk> \<Longrightarrow> sorted_spvec ((aa, y * ba) # addmult_spvec y ((a, b) # arr) brr)"
45.208 + apply (induct brr)
45.209 + apply (auto simp add: sorted_spvec.simps)
45.210 + done
45.211 +
45.212 +lemma sorted_spvec_addmult_spvec_helper2:
45.213 + "\<lbrakk>sorted_spvec (addmult_spvec y arr ((aa, ba) # brr)); a < aa; sorted_spvec ((a, b) # arr); sorted_spvec ((aa, ba) # brr)\<rbrakk>
45.214 + \<Longrightarrow> sorted_spvec ((a, b) # addmult_spvec y arr ((aa, ba) # brr))"
45.215 + apply (induct arr)
45.216 + apply (auto simp add: smult_spvec_def sorted_spvec.simps)
45.217 + done
45.218 +
45.219 +lemma sorted_spvec_addmult_spvec_helper3[rule_format]:
45.220 + "sorted_spvec (addmult_spvec y arr brr) \<longrightarrow> sorted_spvec ((aa, b) # arr) \<longrightarrow> sorted_spvec ((aa, ba) # brr)
45.221 + \<longrightarrow> sorted_spvec ((aa, b + y * ba) # (addmult_spvec y arr brr))"
45.222 + apply (induct y arr brr rule: addmult_spvec.induct)
45.223 + apply (simp_all add: sorted_spvec.simps smult_spvec_def split:list.split)
45.224 + done
45.225 +
45.226 +lemma sorted_addmult_spvec: "sorted_spvec a \<Longrightarrow> sorted_spvec b \<Longrightarrow> sorted_spvec (addmult_spvec y a b)"
45.227 + apply (induct y a b rule: addmult_spvec.induct)
45.228 + apply (simp_all add: sorted_smult_spvec)
45.229 + apply (rule conjI, intro strip)
45.230 + apply (case_tac "~(i < j)")
45.231 + apply (simp_all)
45.232 + apply (frule_tac as=brr in sorted_spvec_cons1)
45.233 + apply (simp add: sorted_spvec_addmult_spvec_helper)
45.234 + apply (intro strip | rule conjI)+
45.235 + apply (frule_tac as=arr in sorted_spvec_cons1)
45.236 + apply (simp add: sorted_spvec_addmult_spvec_helper2)
45.237 + apply (intro strip)
45.238 + apply (frule_tac as=arr in sorted_spvec_cons1)
45.239 + apply (frule_tac as=brr in sorted_spvec_cons1)
45.240 + apply (simp)
45.241 + apply (simp_all add: sorted_spvec_addmult_spvec_helper3)
45.242 + done
45.243 +
45.244 +fun mult_spvec_spmat :: "('a::lattice_ring) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spmat \<Rightarrow> 'a spvec"
45.245 +where
45.246 +(* recdef mult_spvec_spmat "measure (% (c, arr, brr). (length arr) + (length brr))" *)
45.247 + "mult_spvec_spmat c [] brr = c"
45.248 +| "mult_spvec_spmat c arr [] = c"
45.249 +| "mult_spvec_spmat c ((i,a)#arr) ((j,b)#brr) = (
45.250 + if (i < j) then mult_spvec_spmat c arr ((j,b)#brr)
45.251 + else if (j < i) then mult_spvec_spmat c ((i,a)#arr) brr
45.252 + else mult_spvec_spmat (addmult_spvec a c b) arr brr)"
45.253 +
45.254 +lemma sparse_row_mult_spvec_spmat[rule_format]: "sorted_spvec (a::('a::lattice_ring) spvec) \<longrightarrow> sorted_spvec B \<longrightarrow>
45.255 + sparse_row_vector (mult_spvec_spmat c a B) = (sparse_row_vector c) + (sparse_row_vector a) * (sparse_row_matrix B)"
45.256 +proof -
45.257 + have comp_1: "!! a b. a < b \<Longrightarrow> Suc 0 <= nat ((int b)-(int a))" by arith
45.258 + have not_iff: "!! a b. a = b \<Longrightarrow> (~ a) = (~ b)" by simp
45.259 + have max_helper: "!! a b. ~ (a <= max (Suc a) b) \<Longrightarrow> False"
45.260 + by arith
45.261 + {
45.262 + fix a
45.263 + fix v
45.264 + assume a:"a < nrows(sparse_row_vector v)"
45.265 + have b:"nrows(sparse_row_vector v) <= 1" by simp
45.266 + note dummy = less_le_trans[of a "nrows (sparse_row_vector v)" 1, OF a b]
45.267 + then have "a = 0" by simp
45.268 + }
45.269 + note nrows_helper = this
45.270 + show ?thesis
45.271 + apply (induct c a B rule: mult_spvec_spmat.induct)
45.272 + apply simp+
45.273 + apply (rule conjI)
45.274 + apply (intro strip)
45.275 + apply (frule_tac as=brr in sorted_spvec_cons1)
45.276 + apply (simp add: algebra_simps sparse_row_matrix_cons)
45.277 + apply (simplesubst Rep_matrix_zero_imp_mult_zero)
45.278 + apply (simp)
45.279 + apply (rule disjI2)
45.280 + apply (intro strip)
45.281 + apply (subst nrows)
45.282 + apply (rule order_trans[of _ 1])
45.283 + apply (simp add: comp_1)+
45.284 + apply (subst Rep_matrix_zero_imp_mult_zero)
45.285 + apply (intro strip)
45.286 + apply (case_tac "k <= j")
45.287 + apply (rule_tac m1 = k and n1 = i and a1 = a in ssubst[OF sorted_sparse_row_vector_zero])
45.288 + apply (simp_all)
45.289 + apply (rule disjI2)
45.290 + apply (rule nrows)
45.291 + apply (rule order_trans[of _ 1])
45.292 + apply (simp_all add: comp_1)
45.293 +
45.294 + apply (intro strip | rule conjI)+
45.295 + apply (frule_tac as=arr in sorted_spvec_cons1)
45.296 + apply (simp add: algebra_simps)
45.297 + apply (subst Rep_matrix_zero_imp_mult_zero)
45.298 + apply (simp)
45.299 + apply (rule disjI2)
45.300 + apply (intro strip)
45.301 + apply (simp add: sparse_row_matrix_cons)
45.302 + apply (case_tac "i <= j")
45.303 + apply (erule sorted_sparse_row_matrix_zero)
45.304 + apply (simp_all)
45.305 + apply (intro strip)
45.306 + apply (case_tac "i=j")
45.307 + apply (simp_all)
45.308 + apply (frule_tac as=arr in sorted_spvec_cons1)
45.309 + apply (frule_tac as=brr in sorted_spvec_cons1)
45.310 + apply (simp add: sparse_row_matrix_cons algebra_simps sparse_row_vector_addmult_spvec)
45.311 + apply (rule_tac B1 = "sparse_row_matrix brr" in ssubst[OF Rep_matrix_zero_imp_mult_zero])
45.312 + apply (auto)
45.313 + apply (rule sorted_sparse_row_matrix_zero)
45.314 + apply (simp_all)
45.315 + apply (rule_tac A1 = "sparse_row_vector arr" in ssubst[OF Rep_matrix_zero_imp_mult_zero])
45.316 + apply (auto)
45.317 + apply (rule_tac m=k and n = j and a = a and arr=arr in sorted_sparse_row_vector_zero)
45.318 + apply (simp_all)
45.319 + apply (drule nrows_notzero)
45.320 + apply (drule nrows_helper)
45.321 + apply (arith)
45.322 +
45.323 + apply (subst Rep_matrix_inject[symmetric])
45.324 + apply (rule ext)+
45.325 + apply (simp)
45.326 + apply (subst Rep_matrix_mult)
45.327 + apply (rule_tac j1=j in ssubst[OF foldseq_almostzero])
45.328 + apply (simp_all)
45.329 + apply (intro strip, rule conjI)
45.330 + apply (intro strip)
45.331 + apply (drule_tac max_helper)
45.332 + apply (simp)
45.333 + apply (auto)
45.334 + apply (rule zero_imp_mult_zero)
45.335 + apply (rule disjI2)
45.336 + apply (rule nrows)
45.337 + apply (rule order_trans[of _ 1])
45.338 + apply (simp)
45.339 + apply (simp)
45.340 + done
45.341 +qed
45.342 +
45.343 +lemma sorted_mult_spvec_spmat[rule_format]:
45.344 + "sorted_spvec (c::('a::lattice_ring) spvec) \<longrightarrow> sorted_spmat B \<longrightarrow> sorted_spvec (mult_spvec_spmat c a B)"
45.345 + apply (induct c a B rule: mult_spvec_spmat.induct)
45.346 + apply (simp_all add: sorted_addmult_spvec)
45.347 + done
45.348 +
45.349 +primrec mult_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
45.350 +where
45.351 + "mult_spmat [] A = []"
45.352 +| "mult_spmat (a#as) A = (fst a, mult_spvec_spmat [] (snd a) A)#(mult_spmat as A)"
45.353 +
45.354 +lemma sparse_row_mult_spmat:
45.355 + "sorted_spmat A \<Longrightarrow> sorted_spvec B \<Longrightarrow>
45.356 + sparse_row_matrix (mult_spmat A B) = (sparse_row_matrix A) * (sparse_row_matrix B)"
45.357 + apply (induct A)
45.358 + apply (auto simp add: sparse_row_matrix_cons sparse_row_mult_spvec_spmat algebra_simps move_matrix_mult)
45.359 + done
45.360 +
45.361 +lemma sorted_spvec_mult_spmat[rule_format]:
45.362 + "sorted_spvec (A::('a::lattice_ring) spmat) \<longrightarrow> sorted_spvec (mult_spmat A B)"
45.363 + apply (induct A)
45.364 + apply (auto)
45.365 + apply (drule sorted_spvec_cons1, simp)
45.366 + apply (case_tac A)
45.367 + apply (auto simp add: sorted_spvec.simps)
45.368 + done
45.369 +
45.370 +lemma sorted_spmat_mult_spmat:
45.371 + "sorted_spmat (B::('a::lattice_ring) spmat) \<Longrightarrow> sorted_spmat (mult_spmat A B)"
45.372 + apply (induct A)
45.373 + apply (auto simp add: sorted_mult_spvec_spmat)
45.374 + done
45.375 +
45.376 +
45.377 +fun add_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec"
45.378 +where
45.379 +(* "measure (% (a, b). length a + (length b))" *)
45.380 + "add_spvec arr [] = arr"
45.381 +| "add_spvec [] brr = brr"
45.382 +| "add_spvec ((i,a)#arr) ((j,b)#brr) = (
45.383 + if i < j then (i,a)#(add_spvec arr ((j,b)#brr))
45.384 + else if (j < i) then (j,b) # add_spvec ((i,a)#arr) brr
45.385 + else (i, a+b) # add_spvec arr brr)"
45.386 +
45.387 +lemma add_spvec_empty1[simp]: "add_spvec [] a = a"
45.388 +by (cases a, auto)
45.389 +
45.390 +lemma sparse_row_vector_add: "sparse_row_vector (add_spvec a b) = (sparse_row_vector a) + (sparse_row_vector b)"
45.391 + apply (induct a b rule: add_spvec.induct)
45.392 + apply (simp_all add: singleton_matrix_add)
45.393 + done
45.394 +
45.395 +fun add_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
45.396 +where
45.397 +(* "measure (% (A,B). (length A)+(length B))" *)
45.398 + "add_spmat [] bs = bs"
45.399 +| "add_spmat as [] = as"
45.400 +| "add_spmat ((i,a)#as) ((j,b)#bs) = (
45.401 + if i < j then
45.402 + (i,a) # add_spmat as ((j,b)#bs)
45.403 + else if j < i then
45.404 + (j,b) # add_spmat ((i,a)#as) bs
45.405 + else
45.406 + (i, add_spvec a b) # add_spmat as bs)"
45.407 +
45.408 +lemma add_spmat_Nil2[simp]: "add_spmat as [] = as"
45.409 +by(cases as) auto
45.410 +
45.411 +lemma sparse_row_add_spmat: "sparse_row_matrix (add_spmat A B) = (sparse_row_matrix A) + (sparse_row_matrix B)"
45.412 + apply (induct A B rule: add_spmat.induct)
45.413 + apply (auto simp add: sparse_row_matrix_cons sparse_row_vector_add move_matrix_add)
45.414 + done
45.415 +
45.416 +lemmas [code] = sparse_row_add_spmat [symmetric]
45.417 +lemmas [code] = sparse_row_vector_add [symmetric]
45.418 +
45.419 +lemma sorted_add_spvec_helper1[rule_format]: "add_spvec ((a,b)#arr) brr = (ab, bb) # list \<longrightarrow> (ab = a | (brr \<noteq> [] & ab = fst (hd brr)))"
45.420 + proof -
45.421 + have "(! x ab a. x = (a,b)#arr \<longrightarrow> add_spvec x brr = (ab, bb) # list \<longrightarrow> (ab = a | (ab = fst (hd brr))))"
45.422 + by (induct brr rule: add_spvec.induct) (auto split:if_splits)
45.423 + then show ?thesis
45.424 + by (case_tac brr, auto)
45.425 + qed
45.426 +
45.427 +lemma sorted_add_spmat_helper1[rule_format]: "add_spmat ((a,b)#arr) brr = (ab, bb) # list \<longrightarrow> (ab = a | (brr \<noteq> [] & ab = fst (hd brr)))"
45.428 + proof -
45.429 + have "(! x ab a. x = (a,b)#arr \<longrightarrow> add_spmat x brr = (ab, bb) # list \<longrightarrow> (ab = a | (ab = fst (hd brr))))"
45.430 + by (rule add_spmat.induct) (auto split:if_splits)
45.431 + then show ?thesis
45.432 + by (case_tac brr, auto)
45.433 + qed
45.434 +
45.435 +lemma sorted_add_spvec_helper: "add_spvec arr brr = (ab, bb) # list \<Longrightarrow> ((arr \<noteq> [] & ab = fst (hd arr)) | (brr \<noteq> [] & ab = fst (hd brr)))"
45.436 + apply (induct arr brr rule: add_spvec.induct)
45.437 + apply (auto split:if_splits)
45.438 + done
45.439 +
45.440 +lemma sorted_add_spmat_helper: "add_spmat arr brr = (ab, bb) # list \<Longrightarrow> ((arr \<noteq> [] & ab = fst (hd arr)) | (brr \<noteq> [] & ab = fst (hd brr)))"
45.441 + apply (induct arr brr rule: add_spmat.induct)
45.442 + apply (auto split:if_splits)
45.443 + done
45.444 +
45.445 +lemma add_spvec_commute: "add_spvec a b = add_spvec b a"
45.446 +by (induct a b rule: add_spvec.induct) auto
45.447 +
45.448 +lemma add_spmat_commute: "add_spmat a b = add_spmat b a"
45.449 + apply (induct a b rule: add_spmat.induct)
45.450 + apply (simp_all add: add_spvec_commute)
45.451 + done
45.452 +
45.453 +lemma sorted_add_spvec_helper2: "add_spvec ((a,b)#arr) brr = (ab, bb) # list \<Longrightarrow> aa < a \<Longrightarrow> sorted_spvec ((aa, ba) # brr) \<Longrightarrow> aa < ab"
45.454 + apply (drule sorted_add_spvec_helper1)
45.455 + apply (auto)
45.456 + apply (case_tac brr)
45.457 + apply (simp_all)
45.458 + apply (drule_tac sorted_spvec_cons3)
45.459 + apply (simp)
45.460 + done
45.461 +
45.462 +lemma sorted_add_spmat_helper2: "add_spmat ((a,b)#arr) brr = (ab, bb) # list \<Longrightarrow> aa < a \<Longrightarrow> sorted_spvec ((aa, ba) # brr) \<Longrightarrow> aa < ab"
45.463 + apply (drule sorted_add_spmat_helper1)
45.464 + apply (auto)
45.465 + apply (case_tac brr)
45.466 + apply (simp_all)
45.467 + apply (drule_tac sorted_spvec_cons3)
45.468 + apply (simp)
45.469 + done
45.470 +
45.471 +lemma sorted_spvec_add_spvec[rule_format]: "sorted_spvec a \<longrightarrow> sorted_spvec b \<longrightarrow> sorted_spvec (add_spvec a b)"
45.472 + apply (induct a b rule: add_spvec.induct)
45.473 + apply (simp_all)
45.474 + apply (rule conjI)
45.475 + apply (clarsimp)
45.476 + apply (frule_tac as=brr in sorted_spvec_cons1)
45.477 + apply (simp)
45.478 + apply (subst sorted_spvec_step)
45.479 + apply (clarsimp simp: sorted_add_spvec_helper2 split: list.split)
45.480 + apply (clarify)
45.481 + apply (rule conjI)
45.482 + apply (clarify)
45.483 + apply (frule_tac as=arr in sorted_spvec_cons1, simp)
45.484 + apply (subst sorted_spvec_step)
45.485 + apply (clarsimp simp: sorted_add_spvec_helper2 add_spvec_commute split: list.split)
45.486 + apply (clarify)
45.487 + apply (frule_tac as=arr in sorted_spvec_cons1)
45.488 + apply (frule_tac as=brr in sorted_spvec_cons1)
45.489 + apply (simp)
45.490 + apply (subst sorted_spvec_step)
45.491 + apply (simp split: list.split)
45.492 + apply (clarsimp)
45.493 + apply (drule_tac sorted_add_spvec_helper)
45.494 + apply (auto simp: neq_Nil_conv)
45.495 + apply (drule sorted_spvec_cons3)
45.496 + apply (simp)
45.497 + apply (drule sorted_spvec_cons3)
45.498 + apply (simp)
45.499 + done
45.500 +
45.501 +lemma sorted_spvec_add_spmat[rule_format]: "sorted_spvec A \<longrightarrow> sorted_spvec B \<longrightarrow> sorted_spvec (add_spmat A B)"
45.502 + apply (induct A B rule: add_spmat.induct)
45.503 + apply (simp_all)
45.504 + apply (rule conjI)
45.505 + apply (intro strip)
45.506 + apply (simp)
45.507 + apply (frule_tac as=bs in sorted_spvec_cons1)
45.508 + apply (simp)
45.509 + apply (subst sorted_spvec_step)
45.510 + apply (simp split: list.split)
45.511 + apply (clarify, simp)
45.512 + apply (simp add: sorted_add_spmat_helper2)
45.513 + apply (clarify)
45.514 + apply (rule conjI)
45.515 + apply (clarify)
45.516 + apply (frule_tac as=as in sorted_spvec_cons1, simp)
45.517 + apply (subst sorted_spvec_step)
45.518 + apply (clarsimp simp: sorted_add_spmat_helper2 add_spmat_commute split: list.split)
45.519 + apply (clarsimp)
45.520 + apply (frule_tac as=as in sorted_spvec_cons1)
45.521 + apply (frule_tac as=bs in sorted_spvec_cons1)
45.522 + apply (simp)
45.523 + apply (subst sorted_spvec_step)
45.524 + apply (simp split: list.split)
45.525 + apply (clarify, simp)
45.526 + apply (drule_tac sorted_add_spmat_helper)
45.527 + apply (auto simp:neq_Nil_conv)
45.528 + apply (drule sorted_spvec_cons3)
45.529 + apply (simp)
45.530 + apply (drule sorted_spvec_cons3)
45.531 + apply (simp)
45.532 + done
45.533 +
45.534 +lemma sorted_spmat_add_spmat[rule_format]: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (add_spmat A B)"
45.535 + apply (induct A B rule: add_spmat.induct)
45.536 + apply (simp_all add: sorted_spvec_add_spvec)
45.537 + done
45.538 +
45.539 +fun le_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> bool"
45.540 +where
45.541 +(* "measure (% (a,b). (length a) + (length b))" *)
45.542 + "le_spvec [] [] = True"
45.543 +| "le_spvec ((_,a)#as) [] = (a <= 0 & le_spvec as [])"
45.544 +| "le_spvec [] ((_,b)#bs) = (0 <= b & le_spvec [] bs)"
45.545 +| "le_spvec ((i,a)#as) ((j,b)#bs) = (
45.546 + if (i < j) then a <= 0 & le_spvec as ((j,b)#bs)
45.547 + else if (j < i) then 0 <= b & le_spvec ((i,a)#as) bs
45.548 + else a <= b & le_spvec as bs)"
45.549 +
45.550 +fun le_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> bool"
45.551 +where
45.552 +(* "measure (% (a,b). (length a) + (length b))" *)
45.553 + "le_spmat [] [] = True"
45.554 +| "le_spmat ((i,a)#as) [] = (le_spvec a [] & le_spmat as [])"
45.555 +| "le_spmat [] ((j,b)#bs) = (le_spvec [] b & le_spmat [] bs)"
45.556 +| "le_spmat ((i,a)#as) ((j,b)#bs) = (
45.557 + if i < j then (le_spvec a [] & le_spmat as ((j,b)#bs))
45.558 + else if j < i then (le_spvec [] b & le_spmat ((i,a)#as) bs)
45.559 + else (le_spvec a b & le_spmat as bs))"
45.560 +
45.561 +definition disj_matrices :: "('a::zero) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
45.562 + "disj_matrices A B \<longleftrightarrow>
45.563 + (! j i. (Rep_matrix A j i \<noteq> 0) \<longrightarrow> (Rep_matrix B j i = 0)) & (! j i. (Rep_matrix B j i \<noteq> 0) \<longrightarrow> (Rep_matrix A j i = 0))"
45.564 +
45.565 +declare [[simp_depth_limit = 6]]
45.566 +
45.567 +lemma disj_matrices_contr1: "disj_matrices A B \<Longrightarrow> Rep_matrix A j i \<noteq> 0 \<Longrightarrow> Rep_matrix B j i = 0"
45.568 + by (simp add: disj_matrices_def)
45.569 +
45.570 +lemma disj_matrices_contr2: "disj_matrices A B \<Longrightarrow> Rep_matrix B j i \<noteq> 0 \<Longrightarrow> Rep_matrix A j i = 0"
45.571 + by (simp add: disj_matrices_def)
45.572 +
45.573 +
45.574 +lemma disj_matrices_add: "disj_matrices A B \<Longrightarrow> disj_matrices C D \<Longrightarrow> disj_matrices A D \<Longrightarrow> disj_matrices B C \<Longrightarrow>
45.575 + (A + B <= C + D) = (A <= C & B <= (D::('a::lattice_ab_group_add) matrix))"
45.576 + apply (auto)
45.577 + apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
45.578 + apply (intro strip)
45.579 + apply (erule conjE)+
45.580 + apply (drule_tac j=j and i=i in spec2)+
45.581 + apply (case_tac "Rep_matrix B j i = 0")
45.582 + apply (case_tac "Rep_matrix D j i = 0")
45.583 + apply (simp_all)
45.584 + apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
45.585 + apply (intro strip)
45.586 + apply (erule conjE)+
45.587 + apply (drule_tac j=j and i=i in spec2)+
45.588 + apply (case_tac "Rep_matrix A j i = 0")
45.589 + apply (case_tac "Rep_matrix C j i = 0")
45.590 + apply (simp_all)
45.591 + apply (erule add_mono)
45.592 + apply (assumption)
45.593 + done
45.594 +
45.595 +lemma disj_matrices_zero1[simp]: "disj_matrices 0 B"
45.596 +by (simp add: disj_matrices_def)
45.597 +
45.598 +lemma disj_matrices_zero2[simp]: "disj_matrices A 0"
45.599 +by (simp add: disj_matrices_def)
45.600 +
45.601 +lemma disj_matrices_commute: "disj_matrices A B = disj_matrices B A"
45.602 +by (auto simp add: disj_matrices_def)
45.603 +
45.604 +lemma disj_matrices_add_le_zero: "disj_matrices A B \<Longrightarrow>
45.605 + (A + B <= 0) = (A <= 0 & (B::('a::lattice_ab_group_add) matrix) <= 0)"
45.606 +by (rule disj_matrices_add[of A B 0 0, simplified])
45.607 +
45.608 +lemma disj_matrices_add_zero_le: "disj_matrices A B \<Longrightarrow>
45.609 + (0 <= A + B) = (0 <= A & 0 <= (B::('a::lattice_ab_group_add) matrix))"
45.610 +by (rule disj_matrices_add[of 0 0 A B, simplified])
45.611 +
45.612 +lemma disj_matrices_add_x_le: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
45.613 + (A <= B + C) = (A <= C & 0 <= (B::('a::lattice_ab_group_add) matrix))"
45.614 +by (auto simp add: disj_matrices_add[of 0 A B C, simplified])
45.615 +
45.616 +lemma disj_matrices_add_le_x: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
45.617 + (B + A <= C) = (A <= C & (B::('a::lattice_ab_group_add) matrix) <= 0)"
45.618 +by (auto simp add: disj_matrices_add[of B A 0 C,simplified] disj_matrices_commute)
45.619 +
45.620 +lemma disj_sparse_row_singleton: "i <= j \<Longrightarrow> sorted_spvec((j,y)#v) \<Longrightarrow> disj_matrices (sparse_row_vector v) (singleton_matrix 0 i x)"
45.621 + apply (simp add: disj_matrices_def)
45.622 + apply (rule conjI)
45.623 + apply (rule neg_imp)
45.624 + apply (simp)
45.625 + apply (intro strip)
45.626 + apply (rule sorted_sparse_row_vector_zero)
45.627 + apply (simp_all)
45.628 + apply (intro strip)
45.629 + apply (rule sorted_sparse_row_vector_zero)
45.630 + apply (simp_all)
45.631 + done
45.632 +
45.633 +lemma disj_matrices_x_add: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (A::('a::lattice_ab_group_add) matrix) (B+C)"
45.634 + apply (simp add: disj_matrices_def)
45.635 + apply (auto)
45.636 + apply (drule_tac j=j and i=i in spec2)+
45.637 + apply (case_tac "Rep_matrix B j i = 0")
45.638 + apply (case_tac "Rep_matrix C j i = 0")
45.639 + apply (simp_all)
45.640 + done
45.641 +
45.642 +lemma disj_matrices_add_x: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (B+C) (A::('a::lattice_ab_group_add) matrix)"
45.643 + by (simp add: disj_matrices_x_add disj_matrices_commute)
45.644 +
45.645 +lemma disj_singleton_matrices[simp]: "disj_matrices (singleton_matrix j i x) (singleton_matrix u v y) = (j \<noteq> u | i \<noteq> v | x = 0 | y = 0)"
45.646 + by (auto simp add: disj_matrices_def)
45.647 +
45.648 +lemma disj_move_sparse_vec_mat[simplified disj_matrices_commute]:
45.649 + "j <= a \<Longrightarrow> sorted_spvec((a,c)#as) \<Longrightarrow> disj_matrices (move_matrix (sparse_row_vector b) (int j) i) (sparse_row_matrix as)"
45.650 + apply (auto simp add: disj_matrices_def)
45.651 + apply (drule nrows_notzero)
45.652 + apply (drule less_le_trans[OF _ nrows_spvec])
45.653 + apply (subgoal_tac "ja = j")
45.654 + apply (simp add: sorted_sparse_row_matrix_zero)
45.655 + apply (arith)
45.656 + apply (rule nrows)
45.657 + apply (rule order_trans[of _ 1 _])
45.658 + apply (simp)
45.659 + apply (case_tac "nat (int ja - int j) = 0")
45.660 + apply (case_tac "ja = j")
45.661 + apply (simp add: sorted_sparse_row_matrix_zero)
45.662 + apply arith+
45.663 + done
45.664 +
45.665 +lemma disj_move_sparse_row_vector_twice:
45.666 + "j \<noteq> u \<Longrightarrow> disj_matrices (move_matrix (sparse_row_vector a) j i) (move_matrix (sparse_row_vector b) u v)"
45.667 + apply (auto simp add: disj_matrices_def)
45.668 + apply (rule nrows, rule order_trans[of _ 1], simp, drule nrows_notzero, drule less_le_trans[OF _ nrows_spvec], arith)+
45.669 + done
45.670 +
45.671 +lemma le_spvec_iff_sparse_row_le[rule_format]: "(sorted_spvec a) \<longrightarrow> (sorted_spvec b) \<longrightarrow> (le_spvec a b) = (sparse_row_vector a <= sparse_row_vector b)"
45.672 + apply (induct a b rule: le_spvec.induct)
45.673 + apply (simp_all add: sorted_spvec_cons1 disj_matrices_add_le_zero disj_matrices_add_zero_le
45.674 + disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
45.675 + apply (rule conjI, intro strip)
45.676 + apply (simp add: sorted_spvec_cons1)
45.677 + apply (subst disj_matrices_add_x_le)
45.678 + apply (simp add: disj_sparse_row_singleton[OF less_imp_le] disj_matrices_x_add disj_matrices_commute)
45.679 + apply (simp add: disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
45.680 + apply (simp, blast)
45.681 + apply (intro strip, rule conjI, intro strip)
45.682 + apply (simp add: sorted_spvec_cons1)
45.683 + apply (subst disj_matrices_add_le_x)
45.684 + apply (simp_all add: disj_sparse_row_singleton[OF order_refl] disj_sparse_row_singleton[OF less_imp_le] disj_matrices_commute disj_matrices_x_add)
45.685 + apply (blast)
45.686 + apply (intro strip)
45.687 + apply (simp add: sorted_spvec_cons1)
45.688 + apply (case_tac "a=b", simp_all)
45.689 + apply (subst disj_matrices_add)
45.690 + apply (simp_all add: disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
45.691 + done
45.692 +
45.693 +lemma le_spvec_empty2_sparse_row[rule_format]: "sorted_spvec b \<longrightarrow> le_spvec b [] = (sparse_row_vector b <= 0)"
45.694 + apply (induct b)
45.695 + apply (simp_all add: sorted_spvec_cons1)
45.696 + apply (intro strip)
45.697 + apply (subst disj_matrices_add_le_zero)
45.698 + apply (auto simp add: disj_matrices_commute disj_sparse_row_singleton[OF order_refl] sorted_spvec_cons1)
45.699 + done
45.700 +
45.701 +lemma le_spvec_empty1_sparse_row[rule_format]: "(sorted_spvec b) \<longrightarrow> (le_spvec [] b = (0 <= sparse_row_vector b))"
45.702 + apply (induct b)
45.703 + apply (simp_all add: sorted_spvec_cons1)
45.704 + apply (intro strip)
45.705 + apply (subst disj_matrices_add_zero_le)
45.706 + apply (auto simp add: disj_matrices_commute disj_sparse_row_singleton[OF order_refl] sorted_spvec_cons1)
45.707 + done
45.708 +
45.709 +lemma le_spmat_iff_sparse_row_le[rule_format]: "(sorted_spvec A) \<longrightarrow> (sorted_spmat A) \<longrightarrow> (sorted_spvec B) \<longrightarrow> (sorted_spmat B) \<longrightarrow>
45.710 + le_spmat A B = (sparse_row_matrix A <= sparse_row_matrix B)"
45.711 + apply (induct A B rule: le_spmat.induct)
45.712 + apply (simp add: sparse_row_matrix_cons disj_matrices_add_le_zero disj_matrices_add_zero_le disj_move_sparse_vec_mat[OF order_refl]
45.713 + disj_matrices_commute sorted_spvec_cons1 le_spvec_empty2_sparse_row le_spvec_empty1_sparse_row)+
45.714 + apply (rule conjI, intro strip)
45.715 + apply (simp add: sorted_spvec_cons1)
45.716 + apply (subst disj_matrices_add_x_le)
45.717 + apply (rule disj_matrices_add_x)
45.718 + apply (simp add: disj_move_sparse_row_vector_twice)
45.719 + apply (simp add: disj_move_sparse_vec_mat[OF less_imp_le] disj_matrices_commute)
45.720 + apply (simp add: disj_move_sparse_vec_mat[OF order_refl] disj_matrices_commute)
45.721 + apply (simp, blast)
45.722 + apply (intro strip, rule conjI, intro strip)
45.723 + apply (simp add: sorted_spvec_cons1)
45.724 + apply (subst disj_matrices_add_le_x)
45.725 + apply (simp add: disj_move_sparse_vec_mat[OF order_refl])
45.726 + apply (rule disj_matrices_x_add)
45.727 + apply (simp add: disj_move_sparse_row_vector_twice)
45.728 + apply (simp add: disj_move_sparse_vec_mat[OF less_imp_le] disj_matrices_commute)
45.729 + apply (simp, blast)
45.730 + apply (intro strip)
45.731 + apply (case_tac "i=j")
45.732 + apply (simp_all)
45.733 + apply (subst disj_matrices_add)
45.734 + apply (simp_all add: disj_matrices_commute disj_move_sparse_vec_mat[OF order_refl])
45.735 + apply (simp add: sorted_spvec_cons1 le_spvec_iff_sparse_row_le)
45.736 + done
45.737 +
45.738 +declare [[simp_depth_limit = 999]]
45.739 +
45.740 +primrec abs_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat"
45.741 +where
45.742 + "abs_spmat [] = []"
45.743 +| "abs_spmat (a#as) = (fst a, abs_spvec (snd a))#(abs_spmat as)"
45.744 +
45.745 +primrec minus_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat"
45.746 +where
45.747 + "minus_spmat [] = []"
45.748 +| "minus_spmat (a#as) = (fst a, minus_spvec (snd a))#(minus_spmat as)"
45.749 +
45.750 +lemma sparse_row_matrix_minus:
45.751 + "sparse_row_matrix (minus_spmat A) = - (sparse_row_matrix A)"
45.752 + apply (induct A)
45.753 + apply (simp_all add: sparse_row_vector_minus sparse_row_matrix_cons)
45.754 + apply (subst Rep_matrix_inject[symmetric])
45.755 + apply (rule ext)+
45.756 + apply simp
45.757 + done
45.758 +
45.759 +lemma Rep_sparse_row_vector_zero: "x \<noteq> 0 \<Longrightarrow> Rep_matrix (sparse_row_vector v) x y = 0"
45.760 +proof -
45.761 + assume x:"x \<noteq> 0"
45.762 + have r:"nrows (sparse_row_vector v) <= Suc 0" by (rule nrows_spvec)
45.763 + show ?thesis
45.764 + apply (rule nrows)
45.765 + apply (subgoal_tac "Suc 0 <= x")
45.766 + apply (insert r)
45.767 + apply (simp only:)
45.768 + apply (insert x)
45.769 + apply arith
45.770 + done
45.771 +qed
45.772 +
45.773 +lemma sparse_row_matrix_abs:
45.774 + "sorted_spvec A \<Longrightarrow> sorted_spmat A \<Longrightarrow> sparse_row_matrix (abs_spmat A) = abs (sparse_row_matrix A)"
45.775 + apply (induct A)
45.776 + apply (simp_all add: sparse_row_vector_abs sparse_row_matrix_cons)
45.777 + apply (frule_tac sorted_spvec_cons1, simp)
45.778 + apply (simplesubst Rep_matrix_inject[symmetric])
45.779 + apply (rule ext)+
45.780 + apply auto
45.781 + apply (case_tac "x=a")
45.782 + apply (simp)
45.783 + apply (simplesubst sorted_sparse_row_matrix_zero)
45.784 + apply auto
45.785 + apply (simplesubst Rep_sparse_row_vector_zero)
45.786 + apply simp_all
45.787 + done
45.788 +
45.789 +lemma sorted_spvec_minus_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec (minus_spmat A)"
45.790 + apply (induct A)
45.791 + apply (simp)
45.792 + apply (frule sorted_spvec_cons1, simp)
45.793 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.794 + done
45.795 +
45.796 +lemma sorted_spvec_abs_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec (abs_spmat A)"
45.797 + apply (induct A)
45.798 + apply (simp)
45.799 + apply (frule sorted_spvec_cons1, simp)
45.800 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.801 + done
45.802 +
45.803 +lemma sorted_spmat_minus_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat (minus_spmat A)"
45.804 + apply (induct A)
45.805 + apply (simp_all add: sorted_spvec_minus_spvec)
45.806 + done
45.807 +
45.808 +lemma sorted_spmat_abs_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat (abs_spmat A)"
45.809 + apply (induct A)
45.810 + apply (simp_all add: sorted_spvec_abs_spvec)
45.811 + done
45.812 +
45.813 +definition diff_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
45.814 + where "diff_spmat A B = add_spmat A (minus_spmat B)"
45.815 +
45.816 +lemma sorted_spmat_diff_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (diff_spmat A B)"
45.817 + by (simp add: diff_spmat_def sorted_spmat_minus_spmat sorted_spmat_add_spmat)
45.818 +
45.819 +lemma sorted_spvec_diff_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec B \<Longrightarrow> sorted_spvec (diff_spmat A B)"
45.820 + by (simp add: diff_spmat_def sorted_spvec_minus_spmat sorted_spvec_add_spmat)
45.821 +
45.822 +lemma sparse_row_diff_spmat: "sparse_row_matrix (diff_spmat A B ) = (sparse_row_matrix A) - (sparse_row_matrix B)"
45.823 + by (simp add: diff_spmat_def sparse_row_add_spmat sparse_row_matrix_minus)
45.824 +
45.825 +definition sorted_sparse_matrix :: "'a spmat \<Rightarrow> bool"
45.826 + where "sorted_sparse_matrix A \<longleftrightarrow> sorted_spvec A & sorted_spmat A"
45.827 +
45.828 +lemma sorted_sparse_matrix_imp_spvec: "sorted_sparse_matrix A \<Longrightarrow> sorted_spvec A"
45.829 + by (simp add: sorted_sparse_matrix_def)
45.830 +
45.831 +lemma sorted_sparse_matrix_imp_spmat: "sorted_sparse_matrix A \<Longrightarrow> sorted_spmat A"
45.832 + by (simp add: sorted_sparse_matrix_def)
45.833 +
45.834 +lemmas sorted_sp_simps =
45.835 + sorted_spvec.simps
45.836 + sorted_spmat.simps
45.837 + sorted_sparse_matrix_def
45.838 +
45.839 +lemma bool1: "(\<not> True) = False" by blast
45.840 +lemma bool2: "(\<not> False) = True" by blast
45.841 +lemma bool3: "((P\<Colon>bool) \<and> True) = P" by blast
45.842 +lemma bool4: "(True \<and> (P\<Colon>bool)) = P" by blast
45.843 +lemma bool5: "((P\<Colon>bool) \<and> False) = False" by blast
45.844 +lemma bool6: "(False \<and> (P\<Colon>bool)) = False" by blast
45.845 +lemma bool7: "((P\<Colon>bool) \<or> True) = True" by blast
45.846 +lemma bool8: "(True \<or> (P\<Colon>bool)) = True" by blast
45.847 +lemma bool9: "((P\<Colon>bool) \<or> False) = P" by blast
45.848 +lemma bool10: "(False \<or> (P\<Colon>bool)) = P" by blast
45.849 +lemmas boolarith = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10
45.850 +
45.851 +lemma if_case_eq: "(if b then x else y) = (case b of True => x | False => y)" by simp
45.852 +
45.853 +primrec pprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
45.854 +where
45.855 + "pprt_spvec [] = []"
45.856 +| "pprt_spvec (a#as) = (fst a, pprt (snd a)) # (pprt_spvec as)"
45.857 +
45.858 +primrec nprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
45.859 +where
45.860 + "nprt_spvec [] = []"
45.861 +| "nprt_spvec (a#as) = (fst a, nprt (snd a)) # (nprt_spvec as)"
45.862 +
45.863 +primrec pprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
45.864 +where
45.865 + "pprt_spmat [] = []"
45.866 +| "pprt_spmat (a#as) = (fst a, pprt_spvec (snd a))#(pprt_spmat as)"
45.867 +
45.868 +primrec nprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
45.869 +where
45.870 + "nprt_spmat [] = []"
45.871 +| "nprt_spmat (a#as) = (fst a, nprt_spvec (snd a))#(nprt_spmat as)"
45.872 +
45.873 +
45.874 +lemma pprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> pprt (A+B) = pprt A + pprt B"
45.875 + apply (simp add: pprt_def sup_matrix_def)
45.876 + apply (simp add: Rep_matrix_inject[symmetric])
45.877 + apply (rule ext)+
45.878 + apply simp
45.879 + apply (case_tac "Rep_matrix A x xa \<noteq> 0")
45.880 + apply (simp_all add: disj_matrices_contr1)
45.881 + done
45.882 +
45.883 +lemma nprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> nprt (A+B) = nprt A + nprt B"
45.884 + apply (simp add: nprt_def inf_matrix_def)
45.885 + apply (simp add: Rep_matrix_inject[symmetric])
45.886 + apply (rule ext)+
45.887 + apply simp
45.888 + apply (case_tac "Rep_matrix A x xa \<noteq> 0")
45.889 + apply (simp_all add: disj_matrices_contr1)
45.890 + done
45.891 +
45.892 +lemma pprt_singleton[simp]: "pprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (pprt x)"
45.893 + apply (simp add: pprt_def sup_matrix_def)
45.894 + apply (simp add: Rep_matrix_inject[symmetric])
45.895 + apply (rule ext)+
45.896 + apply simp
45.897 + done
45.898 +
45.899 +lemma nprt_singleton[simp]: "nprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (nprt x)"
45.900 + apply (simp add: nprt_def inf_matrix_def)
45.901 + apply (simp add: Rep_matrix_inject[symmetric])
45.902 + apply (rule ext)+
45.903 + apply simp
45.904 + done
45.905 +
45.906 +lemma less_imp_le: "a < b \<Longrightarrow> a <= (b::_::order)" by (simp add: less_def)
45.907 +
45.908 +lemma sparse_row_vector_pprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (pprt_spvec v) = pprt (sparse_row_vector v)"
45.909 + apply (induct v)
45.910 + apply (simp_all)
45.911 + apply (frule sorted_spvec_cons1, auto)
45.912 + apply (subst pprt_add)
45.913 + apply (subst disj_matrices_commute)
45.914 + apply (rule disj_sparse_row_singleton)
45.915 + apply auto
45.916 + done
45.917 +
45.918 +lemma sparse_row_vector_nprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (nprt_spvec v) = nprt (sparse_row_vector v)"
45.919 + apply (induct v)
45.920 + apply (simp_all)
45.921 + apply (frule sorted_spvec_cons1, auto)
45.922 + apply (subst nprt_add)
45.923 + apply (subst disj_matrices_commute)
45.924 + apply (rule disj_sparse_row_singleton)
45.925 + apply auto
45.926 + done
45.927 +
45.928 +
45.929 +lemma pprt_move_matrix: "pprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (pprt A) j i"
45.930 + apply (simp add: pprt_def)
45.931 + apply (simp add: sup_matrix_def)
45.932 + apply (simp add: Rep_matrix_inject[symmetric])
45.933 + apply (rule ext)+
45.934 + apply (simp)
45.935 + done
45.936 +
45.937 +lemma nprt_move_matrix: "nprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (nprt A) j i"
45.938 + apply (simp add: nprt_def)
45.939 + apply (simp add: inf_matrix_def)
45.940 + apply (simp add: Rep_matrix_inject[symmetric])
45.941 + apply (rule ext)+
45.942 + apply (simp)
45.943 + done
45.944 +
45.945 +lemma sparse_row_matrix_pprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (pprt_spmat m) = pprt (sparse_row_matrix m)"
45.946 + apply (induct m)
45.947 + apply simp
45.948 + apply simp
45.949 + apply (frule sorted_spvec_cons1)
45.950 + apply (simp add: sparse_row_matrix_cons sparse_row_vector_pprt)
45.951 + apply (subst pprt_add)
45.952 + apply (subst disj_matrices_commute)
45.953 + apply (rule disj_move_sparse_vec_mat)
45.954 + apply auto
45.955 + apply (simp add: sorted_spvec.simps)
45.956 + apply (simp split: list.split)
45.957 + apply auto
45.958 + apply (simp add: pprt_move_matrix)
45.959 + done
45.960 +
45.961 +lemma sparse_row_matrix_nprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (nprt_spmat m) = nprt (sparse_row_matrix m)"
45.962 + apply (induct m)
45.963 + apply simp
45.964 + apply simp
45.965 + apply (frule sorted_spvec_cons1)
45.966 + apply (simp add: sparse_row_matrix_cons sparse_row_vector_nprt)
45.967 + apply (subst nprt_add)
45.968 + apply (subst disj_matrices_commute)
45.969 + apply (rule disj_move_sparse_vec_mat)
45.970 + apply auto
45.971 + apply (simp add: sorted_spvec.simps)
45.972 + apply (simp split: list.split)
45.973 + apply auto
45.974 + apply (simp add: nprt_move_matrix)
45.975 + done
45.976 +
45.977 +lemma sorted_pprt_spvec: "sorted_spvec v \<Longrightarrow> sorted_spvec (pprt_spvec v)"
45.978 + apply (induct v)
45.979 + apply (simp)
45.980 + apply (frule sorted_spvec_cons1)
45.981 + apply simp
45.982 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.983 + done
45.984 +
45.985 +lemma sorted_nprt_spvec: "sorted_spvec v \<Longrightarrow> sorted_spvec (nprt_spvec v)"
45.986 + apply (induct v)
45.987 + apply (simp)
45.988 + apply (frule sorted_spvec_cons1)
45.989 + apply simp
45.990 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.991 + done
45.992 +
45.993 +lemma sorted_spvec_pprt_spmat: "sorted_spvec m \<Longrightarrow> sorted_spvec (pprt_spmat m)"
45.994 + apply (induct m)
45.995 + apply (simp)
45.996 + apply (frule sorted_spvec_cons1)
45.997 + apply simp
45.998 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.999 + done
45.1000 +
45.1001 +lemma sorted_spvec_nprt_spmat: "sorted_spvec m \<Longrightarrow> sorted_spvec (nprt_spmat m)"
45.1002 + apply (induct m)
45.1003 + apply (simp)
45.1004 + apply (frule sorted_spvec_cons1)
45.1005 + apply simp
45.1006 + apply (simp add: sorted_spvec.simps split:list.split_asm)
45.1007 + done
45.1008 +
45.1009 +lemma sorted_spmat_pprt_spmat: "sorted_spmat m \<Longrightarrow> sorted_spmat (pprt_spmat m)"
45.1010 + apply (induct m)
45.1011 + apply (simp_all add: sorted_pprt_spvec)
45.1012 + done
45.1013 +
45.1014 +lemma sorted_spmat_nprt_spmat: "sorted_spmat m \<Longrightarrow> sorted_spmat (nprt_spmat m)"
45.1015 + apply (induct m)
45.1016 + apply (simp_all add: sorted_nprt_spvec)
45.1017 + done
45.1018 +
45.1019 +definition mult_est_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat" where
45.1020 + "mult_est_spmat r1 r2 s1 s2 =
45.1021 + add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
45.1022 + (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))"
45.1023 +
45.1024 +lemmas sparse_row_matrix_op_simps =
45.1025 + sorted_sparse_matrix_imp_spmat sorted_sparse_matrix_imp_spvec
45.1026 + sparse_row_add_spmat sorted_spvec_add_spmat sorted_spmat_add_spmat
45.1027 + sparse_row_diff_spmat sorted_spvec_diff_spmat sorted_spmat_diff_spmat
45.1028 + sparse_row_matrix_minus sorted_spvec_minus_spmat sorted_spmat_minus_spmat
45.1029 + sparse_row_mult_spmat sorted_spvec_mult_spmat sorted_spmat_mult_spmat
45.1030 + sparse_row_matrix_abs sorted_spvec_abs_spmat sorted_spmat_abs_spmat
45.1031 + le_spmat_iff_sparse_row_le
45.1032 + sparse_row_matrix_pprt sorted_spvec_pprt_spmat sorted_spmat_pprt_spmat
45.1033 + sparse_row_matrix_nprt sorted_spvec_nprt_spmat sorted_spmat_nprt_spmat
45.1034 +
45.1035 +lemma zero_eq_Numeral0: "(0::_::number_ring) = Numeral0" by simp
45.1036 +
45.1037 +lemmas sparse_row_matrix_arith_simps[simplified zero_eq_Numeral0] =
45.1038 + mult_spmat.simps mult_spvec_spmat.simps
45.1039 + addmult_spvec.simps
45.1040 + smult_spvec_empty smult_spvec_cons
45.1041 + add_spmat.simps add_spvec.simps
45.1042 + minus_spmat.simps minus_spvec.simps
45.1043 + abs_spmat.simps abs_spvec.simps
45.1044 + diff_spmat_def
45.1045 + le_spmat.simps le_spvec.simps
45.1046 + pprt_spmat.simps pprt_spvec.simps
45.1047 + nprt_spmat.simps nprt_spvec.simps
45.1048 + mult_est_spmat_def
45.1049 +
45.1050 +
45.1051 +(*lemma spm_linprog_dual_estimate_1:
45.1052 + assumes
45.1053 + "sorted_sparse_matrix A1"
45.1054 + "sorted_sparse_matrix A2"
45.1055 + "sorted_sparse_matrix c1"
45.1056 + "sorted_sparse_matrix c2"
45.1057 + "sorted_sparse_matrix y"
45.1058 + "sorted_spvec b"
45.1059 + "sorted_spvec r"
45.1060 + "le_spmat ([], y)"
45.1061 + "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
45.1062 + "sparse_row_matrix A1 <= A"
45.1063 + "A <= sparse_row_matrix A2"
45.1064 + "sparse_row_matrix c1 <= c"
45.1065 + "c <= sparse_row_matrix c2"
45.1066 + "abs x \<le> sparse_row_matrix r"
45.1067 + shows
45.1068 + "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b, mult_spmat (add_spmat (add_spmat (mult_spmat y (diff_spmat A2 A1),
45.1069 + abs_spmat (diff_spmat (mult_spmat y A1) c1)), diff_spmat c2 c1)) r))"
45.1070 + by (insert prems, simp add: sparse_row_matrix_op_simps linprog_dual_estimate_1[where A=A])
45.1071 +*)
45.1072 +
45.1073 +end
46.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
46.2 +++ b/src/HOL/Matrix_LP/document/root.tex Sat Mar 17 12:52:40 2012 +0100
46.3 @@ -0,0 +1,25 @@
46.4 +\documentclass[11pt,a4paper]{article}
46.5 +\usepackage{isabelle,isabellesym}
46.6 +
46.7 +% this should be the last package used
46.8 +\usepackage{pdfsetup}
46.9 +
46.10 +% urls in roman style, theory text in math-similar italics
46.11 +\urlstyle{rm}
46.12 +\isabellestyle{it}
46.13 +
46.14 +\newcommand{\ganz}{\mathsf{Z}\mkern-7.5mu\mathsf{Z}}
46.15 +
46.16 +\begin{document}
46.17 +
46.18 +\title{Matrix}
46.19 +\author{Steven Obua}
46.20 +\maketitle
46.21 +
46.22 +%\tableofcontents
46.23 +
46.24 +\parindent 0pt\parskip 0.5ex
46.25 +
46.26 +\input{session}
46.27 +
46.28 +\end{document}
47.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
47.2 +++ b/src/HOL/Matrix_LP/fspmlp.ML Sat Mar 17 12:52:40 2012 +0100
47.3 @@ -0,0 +1,313 @@
47.4 +(* Title: HOL/Matrix/fspmlp.ML
47.5 + Author: Steven Obua
47.6 +*)
47.7 +
47.8 +signature FSPMLP =
47.9 +sig
47.10 + type linprog
47.11 + type vector = FloatSparseMatrixBuilder.vector
47.12 + type matrix = FloatSparseMatrixBuilder.matrix
47.13 +
47.14 + val y : linprog -> term
47.15 + val A : linprog -> term * term
47.16 + val b : linprog -> term
47.17 + val c : linprog -> term * term
47.18 + val r12 : linprog -> term * term
47.19 +
47.20 + exception Load of string
47.21 +
47.22 + val load : string -> int -> bool -> linprog
47.23 +end
47.24 +
47.25 +structure Fspmlp : FSPMLP =
47.26 +struct
47.27 +
47.28 +type vector = FloatSparseMatrixBuilder.vector
47.29 +type matrix = FloatSparseMatrixBuilder.matrix
47.30 +
47.31 +type linprog = term * (term * term) * term * (term * term) * (term * term)
47.32 +
47.33 +fun y (c1, _, _, _, _) = c1
47.34 +fun A (_, c2, _, _, _) = c2
47.35 +fun b (_, _, c3, _, _) = c3
47.36 +fun c (_, _, _, c4, _) = c4
47.37 +fun r12 (_, _, _, _, c6) = c6
47.38 +
47.39 +structure CplexFloatSparseMatrixConverter =
47.40 +MAKE_CPLEX_MATRIX_CONVERTER(structure cplex = Cplex and matrix_builder = FloatSparseMatrixBuilder);
47.41 +
47.42 +datatype bound_type = LOWER | UPPER
47.43 +
47.44 +fun intbound_ord ((i1: int, b1),(i2,b2)) =
47.45 + if i1 < i2 then LESS
47.46 + else if i1 = i2 then
47.47 + (if b1 = b2 then EQUAL else if b1=LOWER then LESS else GREATER)
47.48 + else GREATER
47.49 +
47.50 +structure Inttab = Table(type key = int val ord = (rev_order o int_ord));
47.51 +
47.52 +structure VarGraph = Table(type key = int*bound_type val ord = intbound_ord);
47.53 +(* key -> (float option) * (int -> (float * (((float * float) * key) list)))) *)
47.54 +(* dest_key -> (sure_bound * (row_index -> (row_bound * (((coeff_lower * coeff_upper) * src_key) list)))) *)
47.55 +
47.56 +exception Internal of string;
47.57 +
47.58 +fun add_row_bound g dest_key row_index row_bound =
47.59 + let
47.60 + val x =
47.61 + case VarGraph.lookup g dest_key of
47.62 + NONE => (NONE, Inttab.update (row_index, (row_bound, [])) Inttab.empty)
47.63 + | SOME (sure_bound, f) =>
47.64 + (sure_bound,
47.65 + case Inttab.lookup f row_index of
47.66 + NONE => Inttab.update (row_index, (row_bound, [])) f
47.67 + | SOME _ => raise (Internal "add_row_bound"))
47.68 + in
47.69 + VarGraph.update (dest_key, x) g
47.70 + end
47.71 +
47.72 +fun update_sure_bound g (key as (_, btype)) bound =
47.73 + let
47.74 + val x =
47.75 + case VarGraph.lookup g key of
47.76 + NONE => (SOME bound, Inttab.empty)
47.77 + | SOME (NONE, f) => (SOME bound, f)
47.78 + | SOME (SOME old_bound, f) =>
47.79 + (SOME ((case btype of
47.80 + UPPER => Float.min
47.81 + | LOWER => Float.max)
47.82 + old_bound bound), f)
47.83 + in
47.84 + VarGraph.update (key, x) g
47.85 + end
47.86 +
47.87 +fun get_sure_bound g key =
47.88 + case VarGraph.lookup g key of
47.89 + NONE => NONE
47.90 + | SOME (sure_bound, _) => sure_bound
47.91 +
47.92 +(*fun get_row_bound g key row_index =
47.93 + case VarGraph.lookup g key of
47.94 + NONE => NONE
47.95 + | SOME (sure_bound, f) =>
47.96 + (case Inttab.lookup f row_index of
47.97 + NONE => NONE
47.98 + | SOME (row_bound, _) => (sure_bound, row_bound))*)
47.99 +
47.100 +fun add_edge g src_key dest_key row_index coeff =
47.101 + case VarGraph.lookup g dest_key of
47.102 + NONE => raise (Internal "add_edge: dest_key not found")
47.103 + | SOME (sure_bound, f) =>
47.104 + (case Inttab.lookup f row_index of
47.105 + NONE => raise (Internal "add_edge: row_index not found")
47.106 + | SOME (row_bound, sources) =>
47.107 + VarGraph.update (dest_key, (sure_bound, Inttab.update (row_index, (row_bound, (coeff, src_key) :: sources)) f)) g)
47.108 +
47.109 +fun split_graph g =
47.110 + let
47.111 + fun split (key, (sure_bound, _)) (r1, r2) = case sure_bound
47.112 + of NONE => (r1, r2)
47.113 + | SOME bound => (case key
47.114 + of (u, UPPER) => (r1, Inttab.update (u, bound) r2)
47.115 + | (u, LOWER) => (Inttab.update (u, bound) r1, r2))
47.116 + in VarGraph.fold split g (Inttab.empty, Inttab.empty) end
47.117 +
47.118 +(* If safe is true, termination is guaranteed, but the sure bounds may be not optimal (relative to the algorithm).
47.119 + If safe is false, termination is not guaranteed, but on termination the sure bounds are optimal (relative to the algorithm) *)
47.120 +fun propagate_sure_bounds safe names g =
47.121 + let
47.122 + (* returns NONE if no new sure bound could be calculated, otherwise the new sure bound is returned *)
47.123 + fun calc_sure_bound_from_sources g (key as (_, btype)) =
47.124 + let
47.125 + fun mult_upper x (lower, upper) =
47.126 + if Float.sign x = LESS then
47.127 + Float.mult x lower
47.128 + else
47.129 + Float.mult x upper
47.130 +
47.131 + fun mult_lower x (lower, upper) =
47.132 + if Float.sign x = LESS then
47.133 + Float.mult x upper
47.134 + else
47.135 + Float.mult x lower
47.136 +
47.137 + val mult_btype = case btype of UPPER => mult_upper | LOWER => mult_lower
47.138 +
47.139 + fun calc_sure_bound (_, (row_bound, sources)) sure_bound =
47.140 + let
47.141 + fun add_src_bound (coeff, src_key) sum =
47.142 + case sum of
47.143 + NONE => NONE
47.144 + | SOME x =>
47.145 + (case get_sure_bound g src_key of
47.146 + NONE => NONE
47.147 + | SOME src_sure_bound => SOME (Float.add x (mult_btype src_sure_bound coeff)))
47.148 + in
47.149 + case fold add_src_bound sources (SOME row_bound) of
47.150 + NONE => sure_bound
47.151 + | new_sure_bound as (SOME new_bound) =>
47.152 + (case sure_bound of
47.153 + NONE => new_sure_bound
47.154 + | SOME old_bound =>
47.155 + SOME (case btype of
47.156 + UPPER => Float.min old_bound new_bound
47.157 + | LOWER => Float.max old_bound new_bound))
47.158 + end
47.159 + in
47.160 + case VarGraph.lookup g key of
47.161 + NONE => NONE
47.162 + | SOME (sure_bound, f) =>
47.163 + let
47.164 + val x = Inttab.fold calc_sure_bound f sure_bound
47.165 + in
47.166 + if x = sure_bound then NONE else x
47.167 + end
47.168 + end
47.169 +
47.170 + fun propagate (key, _) (g, b) =
47.171 + case calc_sure_bound_from_sources g key of
47.172 + NONE => (g,b)
47.173 + | SOME bound => (update_sure_bound g key bound,
47.174 + if safe then
47.175 + case get_sure_bound g key of
47.176 + NONE => true
47.177 + | _ => b
47.178 + else
47.179 + true)
47.180 +
47.181 + val (g, b) = VarGraph.fold propagate g (g, false)
47.182 + in
47.183 + if b then propagate_sure_bounds safe names g else g
47.184 + end
47.185 +
47.186 +exception Load of string;
47.187 +
47.188 +val empty_spvec = @{term "Nil :: real spvec"};
47.189 +fun cons_spvec x xs = @{term "Cons :: nat * real => real spvec => real spvec"} $ x $ xs;
47.190 +val empty_spmat = @{term "Nil :: real spmat"};
47.191 +fun cons_spmat x xs = @{term "Cons :: nat * real spvec => real spmat => real spmat"} $ x $ xs;
47.192 +
47.193 +fun calcr safe_propagation xlen names prec A b =
47.194 + let
47.195 + fun test_1 (lower, upper) =
47.196 + if lower = upper then
47.197 + (if Float.eq (lower, (~1, 0)) then ~1
47.198 + else if Float.eq (lower, (1, 0)) then 1
47.199 + else 0)
47.200 + else 0
47.201 +
47.202 + fun calcr (row_index, a) g =
47.203 + let
47.204 + val b = FloatSparseMatrixBuilder.v_elem_at b row_index
47.205 + val (_, b2) = FloatArith.approx_decstr_by_bin prec (case b of NONE => "0" | SOME b => b)
47.206 + val approx_a = FloatSparseMatrixBuilder.v_fold (fn (i, s) => fn l =>
47.207 + (i, FloatArith.approx_decstr_by_bin prec s)::l) a []
47.208 +
47.209 + fun fold_dest_nodes (dest_index, dest_value) g =
47.210 + let
47.211 + val dest_test = test_1 dest_value
47.212 + in
47.213 + if dest_test = 0 then
47.214 + g
47.215 + else let
47.216 + val (dest_key as (_, dest_btype), row_bound) =
47.217 + if dest_test = ~1 then
47.218 + ((dest_index, LOWER), Float.neg b2)
47.219 + else
47.220 + ((dest_index, UPPER), b2)
47.221 +
47.222 + fun fold_src_nodes (src_index, src_value as (src_lower, src_upper)) g =
47.223 + if src_index = dest_index then g
47.224 + else
47.225 + let
47.226 + val coeff = case dest_btype of
47.227 + UPPER => (Float.neg src_upper, Float.neg src_lower)
47.228 + | LOWER => src_value
47.229 + in
47.230 + if Float.sign src_lower = LESS then
47.231 + add_edge g (src_index, UPPER) dest_key row_index coeff
47.232 + else
47.233 + add_edge g (src_index, LOWER) dest_key row_index coeff
47.234 + end
47.235 + in
47.236 + fold fold_src_nodes approx_a (add_row_bound g dest_key row_index row_bound)
47.237 + end
47.238 + end
47.239 + in
47.240 + case approx_a of
47.241 + [] => g
47.242 + | [(u, a)] =>
47.243 + let
47.244 + val atest = test_1 a
47.245 + in
47.246 + if atest = ~1 then
47.247 + update_sure_bound g (u, LOWER) (Float.neg b2)
47.248 + else if atest = 1 then
47.249 + update_sure_bound g (u, UPPER) b2
47.250 + else
47.251 + g
47.252 + end
47.253 + | _ => fold fold_dest_nodes approx_a g
47.254 + end
47.255 +
47.256 + val g = FloatSparseMatrixBuilder.m_fold calcr A VarGraph.empty
47.257 +
47.258 + val g = propagate_sure_bounds safe_propagation names g
47.259 +
47.260 + val (r1, r2) = split_graph g
47.261 +
47.262 + fun add_row_entry m index f vname value =
47.263 + let
47.264 + val v = (case value of
47.265 + SOME value => FloatSparseMatrixBuilder.mk_spvec_entry 0 value
47.266 + | NONE => FloatSparseMatrixBuilder.mk_spvec_entry' 0 (f $ (Var ((vname,0), HOLogic.realT))))
47.267 + val vec = cons_spvec v empty_spvec
47.268 + in
47.269 + cons_spmat (FloatSparseMatrixBuilder.mk_spmat_entry index vec) m
47.270 + end
47.271 +
47.272 + fun abs_estimate i r1 r2 =
47.273 + if i = 0 then
47.274 + let val e = empty_spmat in (e, e) end
47.275 + else
47.276 + let
47.277 + val index = xlen-i
47.278 + val (r12_1, r12_2) = abs_estimate (i-1) r1 r2
47.279 + val b1 = Inttab.lookup r1 index
47.280 + val b2 = Inttab.lookup r2 index
47.281 + in
47.282 + (add_row_entry r12_1 index @{term "lbound :: real => real"} ((names index)^"l") b1,
47.283 + add_row_entry r12_2 index @{term "ubound :: real => real"} ((names index)^"u") b2)
47.284 + end
47.285 +
47.286 + val (r1, r2) = abs_estimate xlen r1 r2
47.287 +
47.288 + in
47.289 + (r1, r2)
47.290 + end
47.291 +
47.292 +fun load filename prec safe_propagation =
47.293 + let
47.294 + val prog = Cplex.load_cplexFile filename
47.295 + val prog = Cplex.elim_nonfree_bounds prog
47.296 + val prog = Cplex.relax_strict_ineqs prog
47.297 + val (maximize, c, A, b, (xlen, names, _)) = CplexFloatSparseMatrixConverter.convert_prog prog
47.298 + val (r1, r2) = calcr safe_propagation xlen names prec A b
47.299 + val _ = if maximize then () else raise Load "sorry, cannot handle minimization problems"
47.300 + val (dualprog, indexof) = FloatSparseMatrixBuilder.dual_cplexProg c A b
47.301 + val results = Cplex.solve dualprog
47.302 + val (_, v) = CplexFloatSparseMatrixConverter.convert_results results indexof
47.303 + (*val A = FloatSparseMatrixBuilder.cut_matrix v NONE A*)
47.304 + fun id x = x
47.305 + val v = FloatSparseMatrixBuilder.set_vector FloatSparseMatrixBuilder.empty_matrix 0 v
47.306 + val b = FloatSparseMatrixBuilder.transpose_matrix (FloatSparseMatrixBuilder.set_vector FloatSparseMatrixBuilder.empty_matrix 0 b)
47.307 + val c = FloatSparseMatrixBuilder.set_vector FloatSparseMatrixBuilder.empty_matrix 0 c
47.308 + val (y1, _) = FloatSparseMatrixBuilder.approx_matrix prec Float.positive_part v
47.309 + val A = FloatSparseMatrixBuilder.approx_matrix prec id A
47.310 + val (_,b2) = FloatSparseMatrixBuilder.approx_matrix prec id b
47.311 + val c = FloatSparseMatrixBuilder.approx_matrix prec id c
47.312 + in
47.313 + (y1, A, b2, c, (r1, r2))
47.314 + end handle CplexFloatSparseMatrixConverter.Converter s => (raise (Load ("Converter: "^s)))
47.315 +
47.316 +end
48.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
48.2 +++ b/src/HOL/Matrix_LP/matrixlp.ML Sat Mar 17 12:52:40 2012 +0100
48.3 @@ -0,0 +1,59 @@
48.4 +(* Title: HOL/Matrix/matrixlp.ML
48.5 + Author: Steven Obua
48.6 +*)
48.7 +
48.8 +signature MATRIX_LP =
48.9 +sig
48.10 + val matrix_compute : cterm -> thm
48.11 + val matrix_simplify : thm -> thm
48.12 + val prove_bound : string -> int -> thm
48.13 + val float2real : string * string -> Real.real
48.14 +end
48.15 +
48.16 +structure MatrixLP : MATRIX_LP =
48.17 +struct
48.18 +
48.19 +val compute_thms = ComputeHOL.prep_thms @{thms "ComputeHOL.compute_list_case" "ComputeHOL.compute_let"
48.20 + "ComputeHOL.compute_if" "ComputeFloat.arith" "SparseMatrix.sparse_row_matrix_arith_simps"
48.21 + "ComputeHOL.compute_bool" "ComputeHOL.compute_pair"
48.22 + "SparseMatrix.sorted_sp_simps"
48.23 + "ComputeNumeral.natnorm"}; (*"ComputeNumeral.number_norm"*)
48.24 +
48.25 +val spm_mult_le_dual_prts_no_let_real = @{thm "spm_mult_le_dual_prts_no_let" [where ?'a = real]}
48.26 +
48.27 +fun lp_dual_estimate_prt lptfile prec =
48.28 + let
48.29 + val cert = cterm_of @{theory}
48.30 + fun var s x = (cert (Var ((s, 0), FloatSparseMatrixBuilder.spmatT)), x)
48.31 + val l = Fspmlp.load lptfile prec false
48.32 + val (y, (A1, A2), (c1, c2), b, (r1, r2)) =
48.33 + let
48.34 + open Fspmlp
48.35 + in
48.36 + (y l |> cert, A l |> pairself cert, c l |> pairself cert, b l |> cert, r12 l |> pairself cert)
48.37 + end
48.38 + in
48.39 + Thm.instantiate ([],
48.40 + [var "A1" A1, var "A2" A2, var "y" y, var "c1" c1, var "c2" c2, var "r1" r1, var "r2" r2, var "b" b])
48.41 + spm_mult_le_dual_prts_no_let_real
48.42 + end
48.43 +
48.44 +val computer = PCompute.make Compute.SML @{theory} compute_thms []
48.45 +
48.46 +fun matrix_compute c = hd (PCompute.rewrite computer [c])
48.47 +
48.48 +fun matrix_simplify th =
48.49 + let
48.50 + val simp_th = matrix_compute (cprop_of th)
48.51 + val th = Thm.strip_shyps (Thm.equal_elim simp_th th)
48.52 + fun removeTrue th = removeTrue (Thm.implies_elim th TrueI) handle THM _ => th
48.53 + in
48.54 + removeTrue th
48.55 + end
48.56 +
48.57 +val prove_bound = matrix_simplify oo lp_dual_estimate_prt;
48.58 +
48.59 +val realFromStr = the o Real.fromString;
48.60 +fun float2real (x, y) = realFromStr x * Math.pow (2.0, realFromStr y);
48.61 +
48.62 +end