renamed HOL-Matrix to HOL-Matrix_LP to avoid name clash with AFP;
authorwenzelm
Sat Mar 17 12:52:40 2012 +0100 (2012-03-17)
changeset 469889f492f5b0cec
parent 46987 15ce93dfe6da
child 46989 88b0a8052c75
child 46994 67cf9a6308f3
renamed HOL-Matrix to HOL-Matrix_LP to avoid name clash with AFP;
Admin/isatest/isatest-stats
src/HOL/IsaMakefile
src/HOL/Matrix/ComputeFloat.thy
src/HOL/Matrix/ComputeHOL.thy
src/HOL/Matrix/ComputeNumeral.thy
src/HOL/Matrix/Compute_Oracle/Compute_Oracle.thy
src/HOL/Matrix/Compute_Oracle/am.ML
src/HOL/Matrix/Compute_Oracle/am_compiler.ML
src/HOL/Matrix/Compute_Oracle/am_ghc.ML
src/HOL/Matrix/Compute_Oracle/am_interpreter.ML
src/HOL/Matrix/Compute_Oracle/am_sml.ML
src/HOL/Matrix/Compute_Oracle/compute.ML
src/HOL/Matrix/Compute_Oracle/linker.ML
src/HOL/Matrix/Compute_Oracle/report.ML
src/HOL/Matrix/Cplex.thy
src/HOL/Matrix/CplexMatrixConverter.ML
src/HOL/Matrix/Cplex_tools.ML
src/HOL/Matrix/FloatSparseMatrixBuilder.ML
src/HOL/Matrix/LP.thy
src/HOL/Matrix/Matrix.thy
src/HOL/Matrix/ROOT.ML
src/HOL/Matrix/SparseMatrix.thy
src/HOL/Matrix/document/root.tex
src/HOL/Matrix/fspmlp.ML
src/HOL/Matrix/matrixlp.ML
src/HOL/Matrix_LP/ComputeFloat.thy
src/HOL/Matrix_LP/ComputeHOL.thy
src/HOL/Matrix_LP/ComputeNumeral.thy
src/HOL/Matrix_LP/Compute_Oracle/Compute_Oracle.thy
src/HOL/Matrix_LP/Compute_Oracle/am.ML
src/HOL/Matrix_LP/Compute_Oracle/am_compiler.ML
src/HOL/Matrix_LP/Compute_Oracle/am_ghc.ML
src/HOL/Matrix_LP/Compute_Oracle/am_interpreter.ML
src/HOL/Matrix_LP/Compute_Oracle/am_sml.ML
src/HOL/Matrix_LP/Compute_Oracle/compute.ML
src/HOL/Matrix_LP/Compute_Oracle/linker.ML
src/HOL/Matrix_LP/Compute_Oracle/report.ML
src/HOL/Matrix_LP/Cplex.thy
src/HOL/Matrix_LP/CplexMatrixConverter.ML
src/HOL/Matrix_LP/Cplex_tools.ML
src/HOL/Matrix_LP/FloatSparseMatrixBuilder.ML
src/HOL/Matrix_LP/LP.thy
src/HOL/Matrix_LP/Matrix.thy
src/HOL/Matrix_LP/ROOT.ML
src/HOL/Matrix_LP/SparseMatrix.thy
src/HOL/Matrix_LP/document/root.tex
src/HOL/Matrix_LP/fspmlp.ML
src/HOL/Matrix_LP/matrixlp.ML
     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