diff --git a/thys/ROOTS b/thys/ROOTS --- a/thys/ROOTS +++ b/thys/ROOTS @@ -1,543 +1,544 @@ ADS_Functor AODV Attack_Trees Auto2_HOL Auto2_Imperative_HOL AVL-Trees AWN Abortable_Linearizable_Modules Abs_Int_ITP2012 Abstract-Hoare-Logics Abstract-Rewriting Abstract_Completeness Abstract_Soundness Adaptive_State_Counting Affine_Arithmetic Aggregation_Algebras Akra_Bazzi Algebraic_Numbers Algebraic_VCs Allen_Calculus Amortized_Complexity AnselmGod Applicative_Lifting Approximation_Algorithms Architectural_Design_Patterns Aristotles_Assertoric_Syllogistic Arith_Prog_Rel_Primes ArrowImpossibilityGS AutoFocus-Stream Automated_Stateful_Protocol_Verification Automatic_Refinement AxiomaticCategoryTheory BDD BNF_Operations Banach_Steinhaus Bell_Numbers_Spivey Berlekamp_Zassenhaus Bernoulli Bertrands_Postulate Bicategory BinarySearchTree Binding_Syntax_Theory Binomial-Heaps Binomial-Queues BNF_CC Bondy Boolean_Expression_Checkers Bounded_Deducibility_Security Buchi_Complementation Budan_Fourier Buffons_Needle Buildings BytecodeLogicJmlTypes C2KA_DistributedSystems CAVA_Automata CAVA_LTL_Modelchecker CCS CISC-Kernel CRDT CYK CakeML CakeML_Codegen Call_Arity Card_Equiv_Relations Card_Multisets Card_Number_Partitions Card_Partitions Cartan_FP Case_Labeling Catalan_Numbers Category Category2 Category3 Cauchy Cayley_Hamilton Certification_Monads Chord_Segments Circus Clean ClockSynchInst Closest_Pair_Points CofGroups Coinductive Coinductive_Languages Collections Comparison_Sort_Lower_Bound Compiling-Exceptions-Correctly Completeness Complete_Non_Orders Complex_Geometry Complx ComponentDependencies ConcurrentGC ConcurrentIMP Concurrent_Ref_Alg Concurrent_Revisions Consensus_Refined Constructive_Cryptography Constructor_Funs Containers CoreC++ Core_DOM Count_Complex_Roots CryptHOL CryptoBasedCompositionalProperties DFS_Framework DPT-SAT-Solver DataRefinementIBP Datatype_Order_Generator Decl_Sem_Fun_PL Decreasing-Diagrams Decreasing-Diagrams-II Deep_Learning Density_Compiler Dependent_SIFUM_Refinement Dependent_SIFUM_Type_Systems Depth-First-Search Derangements Deriving Descartes_Sign_Rule Dict_Construction Differential_Dynamic_Logic Differential_Game_Logic Dijkstra_Shortest_Path Diophantine_Eqns_Lin_Hom Dirichlet_L Dirichlet_Series Discrete_Summation DiscretePricing DiskPaxos DynamicArchitectures Dynamic_Tables E_Transcendental Echelon_Form EdmondsKarp_Maxflow Efficient-Mergesort Elliptic_Curves_Group_Law Encodability_Process_Calculi Epistemic_Logic Ergodic_Theory Error_Function Euler_MacLaurin Euler_Partition Example-Submission Factored_Transition_System_Bounding Farkas FFT FLP FOL-Fitting FOL_Harrison FOL_Seq_Calc1 Falling_Factorial_Sum FeatherweightJava Featherweight_OCL Fermat3_4 FileRefinement FinFun Finger-Trees Finite_Automata_HF First_Order_Terms First_Welfare_Theorem Fishburn_Impossibility Fisher_Yates Flow_Networks Floyd_Warshall Flyspeck-Tame FocusStreamsCaseStudies Forcing Formal_SSA Formula_Derivatives Fourier Free-Boolean-Algebra Free-Groups FunWithFunctions FunWithTilings Functional-Automata Functional_Ordered_Resolution_Prover Furstenberg_Topology GPU_Kernel_PL Gabow_SCC Game_Based_Crypto Gauss-Jordan-Elim-Fun Gauss_Jordan Gauss_Sums Gaussian_Integers GenClock General-Triangle Generalized_Counting_Sort Generic_Deriving Generic_Join GewirthPGCProof Girth_Chromatic GoedelGod Goodstein_Lambda GraphMarkingIBP Graph_Saturation Graph_Theory Green Groebner_Bases Groebner_Macaulay Gromov_Hyperbolicity Group-Ring-Module HOL-CSP HOLCF-Prelude HRB-Slicing Heard_Of Hello_World HereditarilyFinite Hermite Hidden_Markov_Models Higher_Order_Terms Hoare_Time HotelKeyCards Huffman Hybrid_Logic Hybrid_Multi_Lane_Spatial_Logic Hybrid_Systems_VCs HyperCTL IEEE_Floating_Point IMAP-CRDT IMO2019 IMP2 IMP2_Binary_Heap IP_Addresses Imperative_Insertion_Sort Impossible_Geometry Incompleteness Incredible_Proof_Machine Inductive_Confidentiality InfPathElimination InformationFlowSlicing InformationFlowSlicing_Inter Integration Interval_Arithmetic_Word32 Iptables_Semantics Irrational_Series_Erdos_Straus Irrationality_J_Hancl Isabelle_C Isabelle_Meta_Model Jacobson_Basic_Algebra Jinja JinjaThreads JiveDataStoreModel Jordan_Hoelder Jordan_Normal_Form KAD KAT_and_DRA KBPs KD_Tree Key_Agreement_Strong_Adversaries Kleene_Algebra Knot_Theory Knuth_Bendix_Order Knuth_Morris_Pratt Koenigsberg_Friendship Kruskal Kuratowski_Closure_Complement LLL_Basis_Reduction LLL_Factorization LOFT LTL LTL_to_DRA LTL_to_GBA LTL_Master_Theorem LTL_Normal_Form Lam-ml-Normalization LambdaAuth LambdaMu Lambda_Free_KBOs Lambda_Free_RPOs Lambert_W Landau_Symbols Laplace_Transform Latin_Square LatticeProperties Lambda_Free_EPO Launchbury Lazy-Lists-II Lazy_Case Lehmer Lifting_Definition_Option LightweightJava LinearQuantifierElim Linear_Inequalities Linear_Programming Linear_Recurrences Liouville_Numbers List-Index List-Infinite List_Interleaving List_Inversions List_Update LocalLexing Localization_Ring Locally-Nameless-Sigma Lowe_Ontological_Argument Lower_Semicontinuous Lp Lucas_Theorem MFMC_Countable MSO_Regex_Equivalence Markov_Models Marriage Mason_Stothers Matrices_for_ODEs Matrix Matrix_Tensor Matroids Max-Card-Matching Median_Of_Medians_Selection Menger Mersenne_Primes MFODL_Monitor_Optimized MFOTL_Monitor MiniML Minimal_SSA Minkowskis_Theorem Minsky_Machines Modal_Logics_for_NTS Modular_Assembly_Kit_Security Monad_Memo_DP Monad_Normalisation MonoBoolTranAlgebra MonoidalCategory Monomorphic_Monad MuchAdoAboutTwo Multirelations Multi_Party_Computation Myhill-Nerode Name_Carrying_Type_Inference Nat-Interval-Logic Native_Word Nested_Multisets_Ordinals Network_Security_Policy_Verification Neumann_Morgenstern_Utility No_FTL_observers Nominal2 Noninterference_CSP Noninterference_Concurrent_Composition Noninterference_Generic_Unwinding Noninterference_Inductive_Unwinding Noninterference_Ipurge_Unwinding Noninterference_Sequential_Composition NormByEval Nullstellensatz Octonions Open_Induction OpSets Optics Optimal_BST Orbit_Stabiliser Order_Lattice_Props Ordered_Resolution_Prover Ordinal Ordinals_and_Cardinals Ordinary_Differential_Equations PCF PLM Pell POPLmark-deBruijn PSemigroupsConvolution Pairing_Heap Paraconsistency Parity_Game Partial_Function_MR Partial_Order_Reduction Password_Authentication_Protocol Perfect-Number-Thm Perron_Frobenius Pi_Calculus Pi_Transcendental Planarity_Certificates Polynomial_Factorization Polynomial_Interpolation Polynomials Poincare_Bendixson Poincare_Disc Pop_Refinement Posix-Lexing Possibilistic_Noninterference Power_Sum_Polynomials Pratt_Certificate Presburger-Automata Prim_Dijkstra_Simple Prime_Distribution_Elementary Prime_Harmonic_Series Prime_Number_Theorem Priority_Queue_Braun Priority_Search_Trees Probabilistic_Noninterference Probabilistic_Prime_Tests Probabilistic_System_Zoo Probabilistic_Timed_Automata Probabilistic_While Projective_Geometry Program-Conflict-Analysis Promela Proof_Strategy_Language PropResPI Propositional_Proof_Systems Prpu_Maxflow PseudoHoops Psi_Calculi Ptolemys_Theorem QHLProver QR_Decomposition Quantales Quaternions Quick_Sort_Cost RIPEMD-160-SPARK ROBDD RSAPSS Ramsey-Infinite Random_BSTs Randomised_BSTs Random_Graph_Subgraph_Threshold Randomised_Social_Choice Rank_Nullity_Theorem Real_Impl Recursion-Addition Recursion-Theory-I Refine_Imperative_HOL Refine_Monadic RefinementReactive Regex_Equivalence Regular-Sets Regular_Algebras Relation_Algebra Relational-Incorrectness-Logic Rep_Fin_Groups Residuated_Lattices Resolution_FOL Rewriting_Z Ribbon_Proofs Robbins-Conjecture Root_Balanced_Tree Routing Roy_Floyd_Warshall SATSolverVerification SDS_Impossibility SIFPL SIFUM_Type_Systems SPARCv8 Safe_OCL Saturation_Framework Secondary_Sylow Security_Protocol_Refinement Selection_Heap_Sort SenSocialChoice Separata Separation_Algebra Separation_Logic_Imperative_HOL SequentInvertibility Shivers-CFA ShortestPath Show Sigma_Commit_Crypto Signature_Groebner Simpl Simple_Firewall Simplex Skew_Heap Skip_Lists Slicing Sliding_Window_Algorithm +Smith_Normal_Form Smooth_Manifolds Sort_Encodings Source_Coding_Theorem Special_Function_Bounds Splay_Tree Sqrt_Babylonian Stable_Matching Statecharts Stateful_Protocol_Composition_and_Typing Stellar_Quorums Stern_Brocot Stewart_Apollonius Stirling_Formula Stochastic_Matrices Stone_Algebras Stone_Kleene_Relation_Algebras Stone_Relation_Algebras Store_Buffer_Reduction Stream-Fusion Stream_Fusion_Code Strong_Security Sturm_Sequences Sturm_Tarski Stuttering_Equivalence Subresultants Subset_Boolean_Algebras SumSquares SuperCalc Surprise_Paradox Symmetric_Polynomials Szpilrajn TESL_Language TLA Tail_Recursive_Functions Tarskis_Geometry Taylor_Models Timed_Automata Topology TortoiseHare Transcendence_Series_Hancl_Rucki Transformer_Semantics Transition_Systems_and_Automata Transitive-Closure Transitive-Closure-II Treaps Tree-Automata Tree_Decomposition Triangle Trie Twelvefold_Way Tycon Types_Tableaus_and_Goedels_God Universal_Turing_Machine UPF UPF_Firewall UpDown_Scheme UTP Valuation VectorSpace VeriComp Verified-Prover VerifyThis2018 VerifyThis2019 Vickrey_Clarke_Groves VolpanoSmith WHATandWHERE_Security WebAssembly Weight_Balanced_Trees Well_Quasi_Orders Winding_Number_Eval WOOT_Strong_Eventual_Consistency Word_Lib WorkerWrapper XML Zeta_Function Zeta_3_Irrational ZFC_in_HOL pGCL diff --git a/thys/Smith_Normal_Form/Admits_SNF_From_Diagonal_Iff_Bezout_Ring.thy b/thys/Smith_Normal_Form/Admits_SNF_From_Diagonal_Iff_Bezout_Ring.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Admits_SNF_From_Diagonal_Iff_Bezout_Ring.thy @@ -0,0 +1,893 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Generality of the Algorithm to transform from diagonal to Smith normal form\ + +theory Admits_SNF_From_Diagonal_Iff_Bezout_Ring + imports + Diagonal_To_Smith + Rings2_Extended + Smith_Normal_Form_JNF + Finite_Field_Mod_Type_Connection +begin + +hide_const (open) mat + +text \This section provides a formal proof on the generality of the algorithm that transforms +a diagonal matrix into its Smith normal form. More concretely, we prove that +all diagonal matrices with coefficients in a ring R admit Smith normal form if and only if +R is a B\'ezout ring. + +Since our algorithm is defined for B\'ezout rings and for any matrices (including non-square and +singular ones), this means that it does not exist another algorithm that performs the transformation +in a more abstract structure.\ + +text \Firstly, we hide some definitions and facts, since we are interested in the ones +developed for the @{text "mod_type"} class.\ + +hide_const (open) Bij_Nat.to_nat Bij_Nat.from_nat Countable.to_nat Countable.from_nat +hide_fact (open) Bij_Nat.to_nat_from_nat_id Bij_Nat.to_nat_less_card + +definition "admits_SNF_HA (A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) = (isDiagonal A + \ (\P Q. invertible ((P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})) + \ invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) \ Smith_normal_form (P**A**Q)))" + +definition "admits_SNF_JNF A = (square_mat (A::'a::comm_ring_1 mat) \ isDiagonal_mat A + \ (\P Q. P \ carrier_mat (dim_row A) (dim_row A) \ Q \ carrier_mat (dim_row A) (dim_row A) + \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat (P*A*Q)))" + + +subsection \Proof of the @{text "\"} implication in HA.\ + +lemma exists_f_PAQ_Aii': + fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}" + assumes diag_A: "isDiagonal A" + shows "\f. (P**A**Q) $h i $h i = (\i\(UNIV::'n set). f i * A $h i $h i)" +proof - + have rw: "(\ka\UNIV. P $h i $h ka * A $h ka $h k) = P $h i $h k * A $h k $h k" for k + proof - + have "(\ka\UNIV. P $h i $h ka * A $h ka $h k) = (\ka\{k}. P $h i $h ka * A $h ka $h k)" + proof (rule sum.mono_neutral_right, auto) + fix ia assume "P $h i $h ia * A $h ia $h k \ 0" + hence "A $h ia $h k \ 0" by auto + thus" ia = k" using diag_A unfolding isDiagonal_def by auto + qed + also have "... = P $h i $h k * A $h k $h k" by auto + finally show ?thesis . + qed + let ?f = "\k. (\ka\UNIV. P $h i $h ka) * Q $h k $h i" + have "(P**A**Q) $h i $h i = (\k\UNIV. (\ka\UNIV. P $h i $h ka * A $h ka $h k) * Q $h k $h i)" + unfolding matrix_matrix_mult_def by auto + also have "... = (\k\UNIV. P $h i $h k * Q $h k $h i * A $h k $h k)" + unfolding rw + by (meson semiring_normalization_rules(16)) + finally show ?thesis by auto +qed + +(*We would like to have the theorems within contexts: + +context semiring_1 +begin + +lemma foo1: + fixes foo::"'a::type\'a\'a" + shows "foo a = c" + sorry + +end + +where 'a has simply type "type". This way, we could have +thm semiring_1.foo + +Which is: class.semiring_1 ?one ?times ?plus ?zero \ ?foo ?a = ?c + +However, many of them are proven with type restrictions instead of being proved within a context. +For example: + +lemma foo2: + fixes foo::"'a::semiring_1\'a\'a" + shows "foo a = c" sorry + +To convert foo2 to a statement like foo1, we need interalize_sort developed in From Types to Sets. + +lemmas foo2 = foo1[internalize_sort "'a :: semiring_1"] +*) + +text \We apply @{text "internalize_sort"} to the lemma that we need\ + +lemmas diagonal_to_Smith_PQ_exists_internalize_sort + = diagonal_to_Smith_PQ_exists[internalize_sort "'a :: bezout_ring"] + +text \We get the @{text "\"} implication in HA.\ + +lemma bezout_ring_imp_diagonal_admits_SNF: + assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)" + shows "\A::'a^'n::{mod_type}^'n::{mod_type}. isDiagonal A + \ (\P Q. + invertible (P::'a^'n::mod_type^'n::mod_type) \ + invertible (Q::'a^'n::mod_type^'n::mod_type) \ + Smith_normal_form (P**A**Q))" +proof (rule allI, rule impI) + fix A::"'a^'n::{mod_type}^'n::{mod_type}" + assume A: "isDiagonal A" + have br: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus" + by (rule OFCLASS_bezout_ring_imp_class_bezout_ring[OF of]) + show "\P Q. + invertible (P::'a^'n::mod_type^'n::mod_type) \ + invertible (Q::'a^'n::mod_type^'n::mod_type) \ + Smith_normal_form (P**A**Q)" by (rule diagonal_to_Smith_PQ_exists_internalize_sort[OF br A]) +qed + +subsection \Trying to prove the @{text "\"} implication in HA.\ + +text\There is a problem: we need to define a matrix with a concrete dimension, which is not + possible in HA (the dimension depends on the number of elements on a set, and Isabelle/HOL does + not feature dependent types)\ + +lemma + assumes "\A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops + +(* +lemma + assumes "\A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A + \ (\P Q. invertible P \ invertible Q \ Smith_normal_form (P**A**Q))" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" +proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI) + fix I::"'a set" + assume fin: "finitely_generated_ideal I" + obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S" + using fin unfolding finitely_generated_ideal_def by auto + obtain xs where set_xs: "set xs = S" and d: "distinct xs" + using finite_distinct_list[OF fin_S] by blast + hence length_eq_card: "length xs = card S" using distinct_card by force +(* + The proof requires: + 1) Obtain a matrix A whose diagonal entries are the elements of xs + 2) Transform such a matrix A into its Smith normal form by means of elementary operations + 3) Put the diagonal entries of the matrix in Smith normal form as a list ys. + 4) Proof that the first element of ys divides all the other elements of such a list. + 5) Show that, ideal_generated (set xs) = ideal_generated (set ys) = ideal_generated (ys!0). +*) + show "principal_ideal I" + +qed + +(*Alternative statement (same problems)*) + +lemma + assumes "\A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops +*) + + +subsection \Proof of the @{text "\"} implication in JNF.\ + +lemma exists_f_PAQ_Aii: + assumes diag_A: "isDiagonal_mat (A::'a:: comm_ring_1 mat)" + and P: "P \ carrier_mat n n" + and A: "A \ carrier_mat n n" + and Q: "Q \ carrier_mat n n" + and i: "i < n" + (* and d: "distinct (diag_mat A)" (*With some work, this assumption can be removed.*)*) + shows "\f. (P*A*Q) $$ (i, i) = (\i\set (diag_mat A). f i * i)" +proof - + let ?xs = "diag_mat A" + let ?n = "length ?xs" + have length_n: "length (diag_mat A) = n" + by (metis A carrier_matD(1) diag_mat_def diff_zero length_map length_upt) + have xs_index: "?xs ! i = A $$ (i, i)" if "ika = 0..ka= 0..ka\{k}. P $$ (i, ka) * A $$ (ka, k))" + by (rule sum.mono_neutral_right, auto simp add: k, + insert diag_A A length_n that, unfold isDiagonal_mat_def, fastforce) + also have "... = P $$(i, k) * A $$ (k, k)" by auto + finally show ?thesis . + qed + let ?positions_of ="\x. {i. A$$(i,i) = x \ i(?positions_of ` ?T) = ?S" unfolding diag_mat_def by auto + have "(P*A*Q) $$ (i,i) = (\ia = 0..(i, j). \ia = 0..k = 0..ka = 0..(i, j). \ia = 0..ia = 0..ia = 0..(i, j). \ia = 0..ka = 0..k = 0..(?positions_of ` ?T))" + using UNION_positions_of by auto + also have "... = (\x\?T. sum ?g (?positions_of x))" + by (rule sum.UNION_disjoint, auto) + also have "... = (\x\set (diag_mat A). (\k\{i. A $$ (i, i) = x \ i < length (diag_mat A)}. + P $$ (i, k) * Q $$ (k, i)) * x)" + by (rule sum.cong, auto simp add: Groups_Big.sum_distrib_right) + finally show ?thesis by auto +qed + +text \Proof of the @{text "\"} implication in JNF.\ + +lemma diagonal_admits_SNF_imp_bezout_ring_JNF: + assumes admits_SNF: "\A n. (A::'a mat) \ carrier_mat n n \ isDiagonal_mat A + \ (\P Q. P \ carrier_mat n n \ Q \ carrier_mat n n \ invertible_mat P \ invertible_mat Q + \ Smith_normal_form_mat (P*A*Q))" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" +proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI) + fix I::"'a set" + assume fin: "finitely_generated_ideal I" + obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S" + using fin unfolding finitely_generated_ideal_def by auto + show "principal_ideal I" + proof (cases "S = {}") + case True + then show ?thesis + by (metis ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def) + next + case False + obtain xs where set_xs: "set xs = S" and d: "distinct xs" + using finite_distinct_list[OF fin_S] by blast + hence length_eq_card: "length xs = card S" using distinct_card by force + let ?n = "length xs" + let ?A = "Matrix.mat ?n ?n (\(a,b). if a = b then xs!a else 0)" + have A_carrier: "?A \ carrier_mat ?n ?n" by auto + have diag_A: "isDiagonal_mat ?A" unfolding isDiagonal_mat_def by auto + have set_xs_eq: "set xs = {?A$$(i,i)| i. i carrier_mat ?n ?n" + and Q: "Q \ carrier_mat ?n ?n" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q" + and SNF_PAQ: "Smith_normal_form_mat (P*?A*Q)" + using admits_SNF A_carrier diag_A by blast + define ys where ys_def: "ys = diag_mat (P*?A*Q)" + have ys: "\i 0" using False set_xs by blast + have set_ys_diag_mat: "set ys = set (diag_mat (P*?A*Q))" using ys_def by auto + let ?i = "ys ! 0" + have dvd_all: "\a \ set ys. ?i dvd a" + proof + fix a assume a: "a \ set ys" + obtain j where ys_j_a: "ys ! j = a" and jn: "j ideal_generated (set ys)" + proof (rule ideal_generated_subset2, rule ballI) + fix b assume b: "b \ set xs" + obtain i where b_A_ii: "b = ?A $$ (i,i)" and i_length: "i inverts_mat P' P" + using inv_P unfolding invertible_mat_def by auto + have P': "P' \ carrier_mat ?n ?n" + using inverts_mat_P' + unfolding carrier_mat_def inverts_mat_def + by (auto,metis P carrier_matD index_mult_mat(3) one_carrier_mat)+ + obtain Q' where inverts_mat_Q': "inverts_mat Q Q' \ inverts_mat Q' Q" + using inv_Q unfolding invertible_mat_def by auto + have Q': "Q' \ carrier_mat ?n ?n" + using inverts_mat_Q' + unfolding carrier_mat_def inverts_mat_def + by (auto,metis Q carrier_matD index_mult_mat(3) one_carrier_mat)+ + have rw_PAQ: "(P'*(P*?A*Q)*Q') $$ (i, i) = ?A $$ (i,i)" + using inv_P'PAQQ'[OF A_carrier P _ _ Q P' Q'] inverts_mat_P' inverts_mat_Q' by auto + have diag_PAQ: "isDiagonal_mat (P*?A*Q)" + using SNF_PAQ unfolding Smith_normal_form_mat_def by auto + have PAQ_carrier: "(P*?A*Q) \ carrier_mat ?n ?n" using P Q by auto + obtain f where f: "(P'*(P*?A*Q)*Q') $$ (i, i) = (\i\set (diag_mat (P*?A*Q)). f i * i)" + using exists_f_PAQ_Aii[OF diag_PAQ P' PAQ_carrier Q' i_length] by auto + hence "?A $$ (i,i) = (\i\set (diag_mat (P*?A*Q)). f i * i)" unfolding rw_PAQ . + thus "b\ ideal_generated (set ys)" + unfolding ideal_explicit using set_ys_diag_mat b_A_ii by auto + qed + show "ideal_generated (set ys) \ ideal_generated (set xs)" + proof (rule ideal_generated_subset2, rule ballI) + fix b assume b: "b \ set ys" + have d: "distinct (diag_mat ?A)" + by (metis (no_types, lifting) A_carrier card_distinct carrier_matD(1) diag_mat_def + length_eq_card length_map map_nth set_xs set_xs_diag_mat) + obtain i where b_PAQ_ii: "(P*?A*Q) $$ (i,i) = b" and i_length: "ii\set (diag_mat ?A). f i * i)" + using exists_f_PAQ_Aii[OF diag_A P _ Q i_length] by auto + thus "b \ ideal_generated (set xs)" + using b_PAQ_ii unfolding set_xs_diag_mat ideal_explicit by auto + qed + qed + also have "... = ideal_generated (set ys - (set ys - {ys!0}))" + proof (rule ideal_generated_dvd_eq_diff_set) + show "?i \ set ys" using n0 + by (simp add: length_ys) + show "?i \ set ys - {?i}" by auto + show "\j\set ys - {?i}. ?i dvd j" using dvd_all by auto + show "finite (set ys - {?i})" by auto + qed + also have "... = ideal_generated {?i}" + by (metis Diff_cancel Diff_not_in insert_Diff insert_Diff_if length_ys n0 nth_mem) + finally show "principal_ideal I" unfolding principal_ideal_def using ig_S by auto + qed +qed + + + +(*Alternative statement:*) +corollary diagonal_admits_SNF_imp_bezout_ring_JNF_alt: + assumes admits_SNF: "\A. square_mat (A::'a mat) \ isDiagonal_mat A +\ (\P Q. P \ carrier_mat (dim_row A) (dim_row A) + \ Q \ carrier_mat (dim_row A) (dim_row A) \ invertible_mat P \ invertible_mat Q + \ Smith_normal_form_mat (P*A*Q))" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" +proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, rule allI, rule allI, rule impI) + fix A::"'a mat" and n assume A: "A \ carrier_mat n n \ isDiagonal_mat A" + have "square_mat A" using A by auto + thus "\P Q. P \ carrier_mat n n \ Q \ carrier_mat n n + \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat (P * A * Q)" + using A admits_SNF by blast +qed + + +subsection \Trying to transfer the @{text "\"} implication to HA.\ + +text \We first hide some constants defined in @{text "Mod_Type_Connect"} in order to use the ones +presented in @{text "Perron_Frobenius.HMA_Connect"} by default.\ + + +context + includes lifting_syntax +begin + +lemma to_nat_mod_type_Bij_Nat: + fixes a::"'n::mod_type" + obtains b::'n where "mod_type_class.to_nat a = Bij_Nat.to_nat b" + using Bij_Nat.to_nat_from_nat_id mod_type_class.to_nat_less_card by metis + +lemma inj_on_Bij_nat_from_nat: "inj_on (Bij_Nat.from_nat::nat \ 'a) {0..This lemma only holds if $a$ and $b$ have the same type. Otherwise, + it is possible that @{text "Bij_Nat.to_nat a = Bij_Nat.to_nat b"}\ + +lemma Bij_Nat_to_nat_neq: + fixes a b ::"'n::mod_type" + assumes "to_nat a \ to_nat b" + shows "Bij_Nat.to_nat a \ Bij_Nat.to_nat b" + using assms to_nat_inj by blast + +text \The following proof (a transfer rule for diagonal matrices) + is weird, since it does not hold + @{text "Bij_Nat.to_nat a = mod_type_class.to_nat a"}. + + At first, it seems possible to obtain the element $a'$ that satisfies + @{text "Bij_Nat.to_nat a' = mod_type_class.to_nat a"} and then continue with the proof, but then + we cannot prove @{text "HMA_I (Bij_Nat.to_nat a') a"}. + + This means that we must use the previous lemma @{text "Bij_Nat_to_nat_neq"}, but this imposes the + matrix to be square. + \ + +lemma HMA_isDiagonal[transfer_rule]: "(HMA_M ===> (=)) + isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'n::{mod_type} => bool))" +proof (intro rel_funI, goal_cases) + case (1 x y) + note rel_xy [transfer_rule] = "1" + have "y $h a $h b = 0" + if all0: "\i j. i \ j \ i < dim_row x \ j < dim_col x \ x $$ (i, j) = 0" + and a_noteq_b: "a \ b" for a::'n and b::'n + proof - + have "to_nat a \ to_nat b" using a_noteq_b by auto + hence distinct: "Bij_Nat.to_nat a \ Bij_Nat.to_nat b" by (rule Bij_Nat_to_nat_neq) + moreover have "Bij_Nat.to_nat a < dim_row x" and "Bij_Nat.to_nat b < dim_col x" + using Bij_Nat.to_nat_less_card dim_row_transfer_rule rel_xy dim_col_transfer_rule + by fastforce+ + ultimately have b: "x $$ (Bij_Nat.to_nat a, Bij_Nat.to_nat b) = 0" using all0 by auto + have [transfer_rule]: "HMA_I (Bij_Nat.to_nat a) a" by (simp add: HMA_I_def) + have [transfer_rule]: "HMA_I (Bij_Nat.to_nat b) b" by (simp add: HMA_I_def) + have "index_hma y a b = 0" using b by (transfer', auto) + thus ?thesis unfolding index_hma_def . + qed + moreover have "x $$ (i, j) = 0" + if all0: "\a b. a \ b \ y $h a $h b = 0" + and ij: "i \ j" and i: "i < dim_row x" and j: "j < dim_col x" for i j + proof - + have i_n: "i < CARD('n)" and j_n: "j < CARD('n)" + using i j rel_xy dim_row_transfer_rule dim_col_transfer_rule + by fastforce+ + let ?i' = "Bij_Nat.from_nat i::'n" + let ?j' = "Bij_Nat.from_nat j::'n" + have i'_neq_j': "?i' \ ?j'" using ij i_n j_n Bij_Nat.from_nat_inj by blast + hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto + have [transfer_rule]: "HMA_I i ?i'" unfolding HMA_I_def + by (simp add: Bij_Nat.to_nat_from_nat_id i_n) + have [transfer_rule]: "HMA_I j ?j'" unfolding HMA_I_def + by (simp add: Bij_Nat.to_nat_from_nat_id j_n) + show ?thesis using y0 by (transfer, auto) + qed + ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def + by auto +qed + +text \Indeed, we can prove the transfer rules with the new connection based on the + @{text "mod_type"} class, which was developed in the @{text "Mod_Type_Connect"} file\ + +text \This is the same lemma as the one presented above, but now using the @{text "to_nat"} function + defined in the @{text "mod_type"} class and then we can prove it for non-square matrices, + which is very useful since our algorithms are not restricted to square matrices.\ + + +lemma HMA_isDiagonal_Mod_Type[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=)) + isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'m::{mod_type} => bool))" +proof (intro rel_funI, goal_cases) + case (1 x y) + note rel_xy [transfer_rule] = "1" + have "y $h a $h b = 0" + if all0: "\i j. i \ j \ i < dim_row x \ j < dim_col x \ x $$ (i, j) = 0" + and a_noteq_b: "to_nat a \ to_nat b" for a::'m and b::'n + proof - + have distinct: "to_nat a \ to_nat b" using a_noteq_b by auto + moreover have "to_nat a < dim_row x" and "to_nat b < dim_col x" + using to_nat_less_card rel_xy + using Mod_Type_Connect.dim_row_transfer_rule Mod_Type_Connect.dim_col_transfer_rule + by fastforce+ + ultimately have b: "x $$ (to_nat a, to_nat b) = 0" using all0 by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a" + by (simp add: Mod_Type_Connect.HMA_I_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b" + by (simp add: Mod_Type_Connect.HMA_I_def) + have "index_hma y a b = 0" using b by (transfer', auto) + thus ?thesis unfolding index_hma_def . + qed + moreover have "x $$ (i, j) = 0" + if all0: "\a b. to_nat a \ to_nat b \ y $h a $h b = 0" + and ij: "i \ j" and i: "i < dim_row x" and j: "j < dim_col x" for i j + proof - + have i_n: "i < CARD('m)" + using i rel_xy by (simp add: Mod_Type_Connect.dim_row_transfer_rule) + have j_n: "j < CARD('n)" + using j rel_xy by (simp add: Mod_Type_Connect.dim_col_transfer_rule) + let ?i' = "from_nat i::'m" + let ?j' = "from_nat j::'n" + have "to_nat ?i' \ to_nat ?j'" + by (simp add: i_n ij j_n mod_type_class.to_nat_from_nat_id) + hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" + unfolding Mod_Type_Connect.HMA_I_def + by (simp add: to_nat_from_nat_id i_n) + have [transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'" + unfolding Mod_Type_Connect.HMA_I_def + by (simp add: to_nat_from_nat_id j_n) + show ?thesis using y0 by (transfer, auto) + qed + ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def + by auto +qed + + +(*We cannot state: + + lemma HMA_SNF[transfer_rule]: "(HMA_M ===> (=)) Smith_normal_form_mat + (Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}\bool)" + +Since we need properties about Suc (Bij_Nat.to_nat a). This means that is mandatory to use +a bridge that relates the JNF representation with the HA one based on indexes with the mod_type +class restriction. This is carried out in the file Mod_Type_Connect. + +Otherwise, I cannot relate + +x $$ (to_nat a, to_nat a) dvd x $$ (to_nat (a + 1), to_nat (a + 1)) + +with + +y $h a $h a dvd y $h (a + 1) $h (a + 1) + +being such to_nat the one presented in Mod_Type, which is not the same as Bij_Nat.to_nat +(mod_type_class.to_nat satisfies more properties that easier the definitions and proofs, +and indeed are fundamental for defining the Smith normal form). +*) + +text\We state the transfer rule using the relations developed in the new bride of the file + @{text "Mod_Type_Connect"}.\ + +lemma HMA_SNF[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=)) Smith_normal_form_mat +(Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'m::{mod_type}\bool)" +proof (intro rel_funI, goal_cases) + case (1 x y) + note rel_xy[transfer_rule] = "1" + have "y $h a $h b dvd y $h (a + 1) $h (b + 1)" + if SNF_condition: "\a. Suc a < dim_row x \ Suc a < dim_col x + \ x $$ (a, a) dvd x $$ (Suc a, Suc a)" + and a1: "Suc (to_nat a) < nrows y" and a2: "Suc (to_nat b) < ncols y" + and ab: "to_nat a = to_nat b" for a::'m and b::'n + proof - + have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a" + by (simp add: Mod_Type_Connect.HMA_I_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (a+1)) (a+1)" + by (simp add: Mod_Type_Connect.HMA_I_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b" + by (simp add: Mod_Type_Connect.HMA_I_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (b+1)) (b+1)" + by (simp add: Mod_Type_Connect.HMA_I_def) + have "Suc (to_nat a) < dim_row x" using a1 + by (metis Mod_Type_Connect.dim_row_transfer_rule nrows_def rel_xy) + moreover have "Suc (to_nat b) < dim_col x" + by (metis Mod_Type_Connect.dim_col_transfer_rule a2 ncols_def rel_xy) + ultimately have "x $$ (to_nat a, to_nat b) dvd x $$ (Suc (to_nat a), Suc (to_nat b))" + using SNF_condition by (simp add: ab) + also have "... = x $$ (to_nat (a+1), to_nat (b+1))" + by (metis Suc_eq_plus1 a1 a2 nrows_def ncols_def to_nat_suc) + finally have SNF_cond: "x $$ (to_nat a, to_nat b) dvd x $$ (to_nat (a + 1), to_nat (b + 1))" . + have "x $$ (to_nat a, to_nat b) = index_hma y a b" by (transfer, simp) + moreover have "x $$ (to_nat (a + 1), to_nat (b + 1)) = index_hma y (a+1) (b+1)" + by (transfer, simp) + ultimately show ?thesis using SNF_cond unfolding index_hma_def by auto + qed + moreover have "x $$ (a, a) dvd x $$ (Suc a, Suc a)" + if SNF: "\a b. to_nat a = to_nat b \ Suc (to_nat a) < nrows y \ Suc (to_nat b) < ncols y + \ y $h a $h b dvd y $h (a + 1) $h (b + 1)" + and a1: "Suc a < dim_row x" and a2: "Suc a < dim_col x" for a + proof - + have dim_row_CARD: "dim_row x = CARD('m)" + using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast + have dim_col_CARD: "dim_col x = CARD('n)" + using Mod_Type_Connect.dim_col_transfer_rule rel_xy by blast + let ?a' = "from_nat a::'m" + let ?b' = "from_nat a::'n" + have Suc_a_less_CARD: "a + 1 < CARD('m)" using a1 dim_row_CARD by auto + have Suc_b_less_CARD: "a + 1 < CARD('n)" using a2 + by (metis Mod_Type_Connect.dim_col_transfer_rule Suc_eq_plus1 rel_xy) + have aa'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?a'" + unfolding Mod_Type_Connect.HMA_I_def + by (metis Suc_a_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id) + have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?a' + 1)" + unfolding Mod_Type_Connect.HMA_I_def + unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_a_less_CARD] by auto + have ab'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?b'" + unfolding Mod_Type_Connect.HMA_I_def + by (metis Suc_b_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id) + have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?b' + 1)" + unfolding Mod_Type_Connect.HMA_I_def + unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_b_less_CARD] by auto + have aa'1: "a = to_nat ?a'" using aa' by (simp add: Mod_Type_Connect.HMA_I_def) + have ab'1: "a = to_nat ?b'" using ab' by (simp add: Mod_Type_Connect.HMA_I_def) + have "Suc (to_nat ?a') < nrows y" using a1 dim_row_CARD + by (simp add: mod_type_class.to_nat_from_nat_id nrows_def) + moreover have "Suc (to_nat ?b') < ncols y" using a2 dim_col_CARD + by (simp add: mod_type_class.to_nat_from_nat_id ncols_def) + ultimately have SNF': "y $h ?a' $h ?b' dvd y $h (?a' + 1) $h (?b' + 1)" + using SNF ab'1 aa'1 by auto + have "index_hma y ?a' ?b' = x $$ (a, a)" by (transfer, simp) + moreover have "index_hma y (?a'+1) (?b'+1) = x $$ (a+1, a+1)" by (transfer, simp) + ultimately show ?thesis using SNF' unfolding index_hma_def by auto + qed + ultimately show ?case unfolding Smith_normal_form_mat_def Smith_normal_form_def + using rel_xy by (auto) (transfer', auto)+ +qed + + + +lemma HMA_admits_SNF [transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'n::{mod_type} ^ 'n::{mod_type} \ _) ===> (=)) + admits_SNF_JNF admits_SNF_HA" +proof (intro rel_funI, goal_cases) + case (1 x y) + note [transfer_rule] = this + hence id: "dim_row x = CARD('n)" by (auto simp: Mod_Type_Connect.HMA_M_def) + then show ?case unfolding admits_SNF_JNF_def admits_SNF_HA_def + by (transfer, auto, metis "1" Mod_Type_Connect.dim_col_transfer_rule) +qed +end + + + +(*If the following result holds, then I will get the result. + + But the theorem is false, since the assumption fixes the type 'n (within the proof is not + arbitrary any more). We cannot quantify over type variables in Isabelle/HOL.*) + +(* +lemma diagonal_admits_SNF_imp_bezout_ring_JNF3: + assumes admits_SNF: "\A. (A::'a mat) \ carrier_mat (CARD('n)) (CARD('n)) \ isDiagonal_mat A +\ (\P Q. P \ carrier_mat (dim_row A) (dim_row A) + \ Q \ carrier_mat (dim_row A) (dim_row A) \ invertible_mat P \ invertible_mat Q + \ Smith_normal_form_mat (P*A*Q))" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" + apply (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto) +*) + + +text\Here we have a problem when trying to apply local type definitions\ +(* +Once the assumption is translated to JNF, we get that it holds for all matrices with +CARD('n) rows and CARD('n) columns. That is, we do not have the result for any matrix, just +for matrices of such dimensions (within the proof, the type 'n is not arbitrary, is fixed). +*) +lemma diagonal_admits_SNF_imp_bezout_ring: + assumes admits_SNF: "\A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A + \ (\P Q. invertible (P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) + \ invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) + \ Smith_normal_form (P**A**Q))" + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" +proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto) + fix A::"'a mat" and n + assume A: "A \ carrier_mat n n" and diag_A: "isDiagonal_mat A" + have a: "\A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A" + using admits_SNF unfolding admits_SNF_HA_def . + have JNF: "\(A::'a mat)\ carrier_mat CARD('n) CARD('n). admits_SNF_JNF A" + (*We can get this result, but this does not imply that it holds for any n \ n matrix, just + for the concrete case that n = CARD('n). Within this proof, we cannot apply local type + definitions, since the 'n is not an schematic variable any more, it is fixed.*) + proof + fix A::"'a mat" + assume A: "A \ carrier_mat CARD('n) CARD('n)" + let ?B = "(Mod_Type_Connect.to_hma\<^sub>m A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})" + have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?B" + using A unfolding Mod_Type_Connect.HMA_M_def by auto + have b: "admits_SNF_HA ?B" using a by auto + show "admits_SNF_JNF A" using b by transfer + qed + (*Here we cannot apply local type definitions (either cancel_card_constraint or + cancel_type_definition) to thm JNF*) + thus "\P. P \ carrier_mat n n \ + (\Q. Q \ carrier_mat n n \ invertible_mat P + \ invertible_mat Q \ Smith_normal_form_mat (P * A * Q))" + using JNF A diag_A unfolding admits_SNF_JNF_def unfolding square_mat.simps oops + + +text\This means that the @{text "\"} implication cannot be proven in HA, since we cannot quantify +over type variables in Isabelle/HOL. We then prove both implications in JNF.\ + + +subsection \Transfering the @{text "\"} implication from HA to JNF using transfer rules + and local type definitions\ + +(* + I need to transfer the theorem bezout_ring_imp_diagonal_admits_SNF (stated in HA) to JNF. + The first necessary step is to prove transfer rules to connect matrices in HA (when the type + of the indexes must be mod_type). The original connection HMA_Connect presented in the + Perron--Frobenius development just connects matrices of type 'a^'b::finite^'c::finite with + the corresponding ones in JNF, but I need to transfer theorems with matrices of type: + 'a^'b::mod_type^'c::mod_type. + + The file that allows this bridge is Mod_Type_Connect. + + Once that step is carried out, I would have to transfer the result by means of the lifting + and transfer package and then apply local type definitions to get rid of the type (that is, + to change CARD('n) by an arbitrary n). + + The usual approach consists of applying lifting and transfer to the theorem, and then we + obtain a fact like + + A \ carrier_mat (CARD('n::mod_type)) (CARD('n::mod_type)) + + When trying to apply local type definitions (to substitute CARD('n::mod_type) by n), then + I would have to apply interalize_sort and then proving the restriction class.mod_type (together + with the operations associated to that class). Since the mod_type class already introduced + several type restrictions (times, neg_numeral_well_order), operations (+,-) and constants (1,0), + this means that we have to proceed using dictionary construction. We would have to define + a mod_type with explicit operations, to get 'a only of type 'a::type. + + definition "mod_type_with n (tms::'a\'a\'a) mns pls zr umns (one'::'a) + (less_eq'::'a\'a\bool) (less'::'a\'a\bool) (Rep_op::'a\int) (Abs_op::int\'a) + \ (type_definition Rep_op Abs_op {0.. 1 < n + \ (zr = Abs_op 0) + \ (one' = Abs_op 1) + \ (\x y. pls x y = Abs_op (((Rep_op x) + (Rep_op y)) mod (n))) + \ (\x y. tms x y = Abs_op (((Rep_op x) * (Rep_op y)) mod (n))) + \ (\x y. mns x y = Abs_op (((Rep_op x) - (Rep_op y)) mod (n))) + \ (\x. umns x = Abs_op ((- (Rep_op x)) mod (n))) + \ (\x y. less' x y \ (Rep_op x) < (Rep_op y)) + \ class.neg_numeral mns pls zr umns + \ class.wellorder less_eq' less')" + + Once this is completed, I would have to connect mod_type and mod_type_with, + prove new transfer rules and so on. This is the usual approach and has been successfully applied, + for instance, by Fabian Immler to transform a (type based) library of linear algebra into another + one with explicit carriers. + + Fortunately, in this case there is a shortcut: we can use the type 'a mod_ring from the + Berlekamp--Zassenhaus development to express the lemma in HA + (thm bezout_ring_imp_diagonal_admits_SNF) using that type (the type 'a mod_ring is an instance + of the mod_type class, and then is a particular case). + + This means that any lemma that has a matrix of type 'a^'b::mod_type^'c^'mod_type can be expressed + as 'a^'b mod_ring^'c mod_ring, where 'b and 'c must satisfy the nontriv restriction + (they must have more than one element). + + This is done in the file Finite_Field_Mod_Type_Connection, which shows that 'a mod_ring is an + instance of the mod_type class. + + This type 'a mod_ring has a very useful property: CARD('b mod_ring) = CARD('b) + This means that it is very easy to apply local type definitions. The problematic fact + would then be transformed to: + + A \ carrier_mat (CARD('n::nontriv)) (CARD('n::nontriv)). + + It is very easy to apply local type definitions to this fact, since it is very easy to get rid + of the nontriv restriction (on the contrary, the mod_type restriction was quite hard). + +*) + + +(* + In our concrete case: we write the theorem in terms of the mod_ring type thanks to + the file Finite_Field_Mod_Type_Connection. + + With this type 'n::nontriv mod_ring I can easily apply local type definitions, since we + will get CARD(?'n::nontriv). +*) + +lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring: + assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)" + shows "\A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. isDiagonal A + \ (\P Q. + invertible (P::'a^'n::nontriv mod_ring^'n::nontriv mod_ring) \ + invertible (Q::'a^'n::nontriv mod_ring^'n::nontriv mod_ring) \ + Smith_normal_form (P**A**Q))" + using bezout_ring_imp_diagonal_admits_SNF[OF assms] by auto + +lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits: + assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus" (*It is equivalent to the statement based on OFCLASS*) + shows "\A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. admits_SNF_HA A" + using bezout_ring_imp_diagonal_admits_SNF + [OF Rings2.class.Rings2.bezout_ring.of_class.intro[OF of]] + unfolding admits_SNF_HA_def by auto + +text\I start here to apply local type definitions\ + +context + fixes p::nat + assumes local_typedef: "\(Rep :: ('b \ int)) Abs. type_definition Rep Abs {0..

1" +begin + +lemma type_to_set: + shows "class.nontriv TYPE('b)" (is ?a) and "p=CARD('b)" (is ?b) +proof - + from local_typedef obtain Rep::"('b \ int)" and Abs + where t: "type_definition Rep Abs {0..

I transfer the lemma from HA to JNF, substituting @{text "CARD('n)"} by $p$. + I apply @{text "internalize-sort"} to @{text "'n"} and get rid of + the @{text "nontriv"} restriction.\ + +lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux: + assumes "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus" + shows "Ball {A::'a::comm_ring_1 mat. A \ carrier_mat p p} admits_SNF_JNF" + using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits[untransferred, unfolded CARD_mod_ring, + internalize_sort "'n::nontriv", where ?'a='b] + unfolding type_to_set(2)[symmetric] using type_to_set(1) assms by auto +end + +text\The @{text "\"} implication in JNF\ + +text\Since @{text "nontriv"} imposes the type to have more than one element, + the cases $n=0$ (@{text "A \ carrier_mat 0 0"}) and $n = 1$ (@{text "A \ carrier_mat 1 1"}) + must be treated separately.\ + +lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2: + assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus" + shows "\(A::'a mat)\carrier_mat n n. admits_SNF_JNF A" +proof (cases "n = 0") + case True + show ?thesis + by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def + Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, fastforce) +next + case False note not0 = False + show ?thesis + proof (cases "n=1") + case True + show ?thesis + by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def + Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, auto) + (metis dvd_1_left index_one_mat(2) index_one_mat(3) less_Suc0 nat_dvd_not_less + right_mult_one_mat' zero_less_Suc) + next + case False + then have "n>1" using not0 by auto + then show ?thesis (*Here I apply the local type definition rule, to cancel the type*) + using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux[cancel_type_definition, of n] of + by auto + qed +qed + +text \Alternative statements\ + +lemma bezout_ring_imp_diagonal_admits_SNF_JNF: + assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus" + shows "\A::'a mat. admits_SNF_JNF A" +proof + fix A::"'a mat" + have "A\ carrier_mat (dim_row A) (dim_col A)" unfolding carrier_mat_def by auto + thus "admits_SNF_JNF A" + using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2[OF of] + by (metis admits_SNF_JNF_def square_mat.elims(2)) +qed + + +lemma admits_SNF_JNF_alt_def: + "(\A::'a::comm_ring_1 mat. admits_SNF_JNF A) + = (\A n. (A::'a mat) \ carrier_mat n n \ isDiagonal_mat A + \ (\P Q. P \ carrier_mat n n \ Q \ carrier_mat n n \ invertible_mat P \ invertible_mat Q + \ Smith_normal_form_mat (P*A*Q)))" (is "?a = ?b") + by (auto simp add: admits_SNF_JNF_def, metis carrier_matD(1) carrier_matD(2), blast) + + +subsection \Final theorem in JNF\ +text \Final theorem using @{text "class.bezout_ring"}\ + +theorem diagonal_admits_SNF_iff_bezout_ring: + shows "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus + \ (\A::'a mat. admits_SNF_JNF A)" (is "?a \ ?b") +proof + assume ?a + thus ?b using bezout_ring_imp_diagonal_admits_SNF_JNF by auto +next + assume b: ?b + have rw: "\A n. (A::'a mat) \ carrier_mat n n \ isDiagonal_mat A \ + (\P Q. P \ carrier_mat n n \ Q \ carrier_mat n n \ invertible_mat P + \ invertible_mat Q \ Smith_normal_form_mat (P * A * Q))" + using admits_SNF_JNF_alt_def b by auto + show ?a + using diagonal_admits_SNF_imp_bezout_ring_JNF[OF rw] + using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a] + by auto +qed + +text \Final theorem using @{text "OFCLASS"}\ + +theorem diagonal_admits_SNF_iff_bezout_ring': + shows "OFCLASS('a::comm_ring_1, bezout_ring_class) \ (\A::'a mat. admits_SNF_JNF A)" +proof + fix A::"'a mat" + assume a: "OFCLASS('a, bezout_ring_class)" + show "admits_SNF_JNF A" + using OFCLASS_bezout_ring_imp_class_bezout_ring[OF a] diagonal_admits_SNF_iff_bezout_ring + by auto +next + assume "(\A::'a mat. admits_SNF_JNF A)" + hence *: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus" + using diagonal_admits_SNF_iff_bezout_ring by auto + show "OFCLASS('a, bezout_ring_class)" + by (rule Rings2.class.Rings2.bezout_ring.of_class.intro, rule *) +qed + +end diff --git a/thys/Smith_Normal_Form/Cauchy_Binet.thy b/thys/Smith_Normal_Form/Cauchy_Binet.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Cauchy_Binet.thy @@ -0,0 +1,1426 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \The Cauchy--Binet formula\ + +theory Cauchy_Binet + imports + Diagonal_To_Smith + SNF_Missing_Lemmas +begin + +subsection \Previous missing results about @{text "pick"} and @{text "insert"}\ + +lemma pick_insert: + assumes a_notin_I: "a \ I" and i2: "i < card I" + and a_def: "pick (insert a I) a' = a" (*Alternative: index (insort a (sorted_list_of_set I)) a = a'*) + and ia': "i < a'" (*Case 1*) + and a'_card: "a' < card I + 1" + shows "pick (insert a I) i = pick I i" +proof - + have finI: "finite I" + using i2 + using card_infinite by force + have "pick (insert a I) i = sorted_list_of_set (insert a I) ! i" + proof (rule sorted_list_of_set_eq_pick[symmetric]) + have "finite (insert a I)" + using card_infinite i2 by force + thus "i < length (sorted_list_of_set (insert a I))" + by (metis a_notin_I card_insert_disjoint distinct_card finite_insert + i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3)) + qed + also have "... = insort a (sorted_list_of_set I) ! i" + using sorted_list_of_set.insert + by (metis a_notin_I card_infinite i2 not_less0) + also have "... = (sorted_list_of_set I) ! i" + proof (rule insort_nth[OF]) + show "sorted (sorted_list_of_set I)" by auto + show "a \ set (sorted_list_of_set I)" using a_notin_I + by (metis card_infinite i2 not_less_zero set_sorted_list_of_set) + have "index (sorted_list_of_set (insert a I)) a = a'" + using pick_index a_def + using a'_card a_notin_I finI by auto + hence "index (insort a (sorted_list_of_set I)) a = a'" + by (simp add: a_notin_I finI) + thus "i < index (insort a (sorted_list_of_set I)) a" using ia' by auto + show "sorted_list_of_set I \ []" using finI i2 by fastforce + qed + also have "... = pick I i" + proof (rule sorted_list_of_set_eq_pick) + have "finite I" using card_infinite i2 by fastforce + thus "i < length (sorted_list_of_set I)" + by (metis distinct_card distinct_sorted_list_of_set i2 set_sorted_list_of_set) + qed + finally show ?thesis . +qed + + +lemma pick_insert2: + assumes a_notin_I: "a \ I" and i2: "i < card I" + and a_def: "pick (insert a I) a' = a" (*Alternative: index (sorted_list_of_set (insert a I)) a = a'*) + and ia': "i \ a'" (*Case 2*) + and a'_card: "a' < card I + 1" + shows "pick (insert a I) i < pick I i" +proof (cases "i = 0") + case True + then show ?thesis + by (auto, metis (mono_tags, lifting) DL_Missing_Sublist.pick.simps(1) Least_le a_def a_notin_I + dual_order.order_iff_strict i2 ia' insertCI le_zero_eq not_less_Least pick_in_set_le) +next + case False + hence i0: "i = Suc (i - 1)" using a'_card ia' by auto + have finI: "finite I" + using i2 card_infinite by force + have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'" + using pick_index + using a'_card a_def a_notin_I finI by auto + hence index_a': "index (insort a (sorted_list_of_set I)) a = a'" + by (simp add: a_notin_I finI) + have i1_length: "i - 1 < length (sorted_list_of_set I)" using i2 + by (metis distinct_card distinct_sorted_list_of_set finI + less_imp_diff_less set_sorted_list_of_set) + have 1: "pick (insert a I) i = sorted_list_of_set (insert a I) ! i" + proof (rule sorted_list_of_set_eq_pick[symmetric]) + have "finite (insert a I)" + using card_infinite i2 by force + thus "i < length (sorted_list_of_set (insert a I))" + by (metis a_notin_I card_insert_disjoint distinct_card finite_insert + i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3)) + qed + also have 2: "... = insort a (sorted_list_of_set I) ! i" + using sorted_list_of_set.insert + by (metis a_notin_I card_infinite i2 not_less0) + also have "... = insort a (sorted_list_of_set I) ! Suc (i-1)" using i0 by auto + also have "... < pick I i" + proof (cases "i = a'") + case True + have "(sorted_list_of_set I) ! i > a" + by (smt "1" Suc_less_eq True a_def a_notin_I distinct_card distinct_sorted_list_of_set finI i2 + ia' index_a' insort_nth2 length_insort lessI list.size(3) nat_less_le not_less_zero + pick_in_set_le set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set.insert + sorted_list_of_set_eq_pick sorted_sorted_wrt sorted_wrt_nth_less) + moreover have "a = insort a (sorted_list_of_set I) ! i" using True 1 2 a_def by auto + ultimately show ?thesis using 1 2 + by (metis distinct_card finI i0 i2 set_sorted_list_of_set + sorted_list_of_set(3) sorted_list_of_set_eq_pick) + next + case False + have "insort a (sorted_list_of_set I) ! Suc (i-1) = (sorted_list_of_set I) ! (i-1)" + by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI) + also have "... = pick I (i-1)" + by (rule sorted_list_of_set_eq_pick[OF i1_length]) + also have "... < pick I i" using i0 i2 pick_mono_le by auto + finally show ?thesis . + qed + finally show ?thesis . +qed + +lemma pick_insert3: + assumes a_notin_I: "a \ I" and i2: "i < card I" + and a_def: "pick (insert a I) a' = a" (*Alternative: index (sorted_list_of_set (insert a I)) a = a'.*) + and ia': "i \ a'" (*Case 2*) + and a'_card: "a' < card I + 1" + shows "pick (insert a I) (Suc i) = pick I i" +proof (cases "i = 0") + case True + have a_LEAST: "a < (LEAST aa. aa\I)" + using True a_def a_notin_I i2 ia' pick_insert2 by fastforce + have Least_rw: "(LEAST aa. aa = a \ aa \ I) = a" + by (rule Least_equality, insert a_notin_I, auto, + metis a_LEAST le_less_trans nat_le_linear not_less_Least) + let ?P = "\aa. (aa = a \ aa \ I) \ (LEAST aa. aa = a \ aa \ I) < aa" + let ?Q = "\aa. aa \ I" + have "?P = ?Q" unfolding Least_rw fun_eq_iff + by (auto, metis a_LEAST le_less_trans not_le not_less_Least) + thus ?thesis using True by auto +next + case False + have finI: "finite I" + using i2 card_infinite by force + have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'" + using pick_index + using a'_card a_def a_notin_I finI by auto + hence index_a': "index (insort a (sorted_list_of_set I)) a = a'" + by (simp add: a_notin_I finI) + have i1_length: "i < length (sorted_list_of_set I)" using i2 + by (metis distinct_card distinct_sorted_list_of_set finI set_sorted_list_of_set) + have 1: "pick (insert a I) (Suc i) = sorted_list_of_set (insert a I) ! (Suc i)" + proof (rule sorted_list_of_set_eq_pick[symmetric]) + have "finite (insert a I)" + using card_infinite i2 by force + thus "Suc i < length (sorted_list_of_set (insert a I))" + by (metis Suc_mono a_notin_I card_insert_disjoint distinct_card distinct_sorted_list_of_set + finI i2 set_sorted_list_of_set) + qed + also have 2: "... = insort a (sorted_list_of_set I) ! Suc i" + using sorted_list_of_set.insert + by (metis a_notin_I card_infinite i2 not_less0) + also have "... = pick I i" + proof (cases "i = a'") + case True + show ?thesis + by (metis True a_notin_I finI i1_length index_a' insort_nth2 le_refl list.size(3) not_less0 + set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set_eq_pick) + next + case False + have "insort a (sorted_list_of_set I) ! Suc i = (sorted_list_of_set I) ! i" + by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI) + also have "... = pick I i" + by (rule sorted_list_of_set_eq_pick[OF i1_length]) + finally show ?thesis . + qed + finally show ?thesis . +qed + + +lemma pick_insert_index: + assumes Ik: "card I = k" + and a_notin_I: "a \ I" + and ik: "i < k" + and a_def: "pick (insert a I) a' = a" + and a'k: "a' < card I + 1" +shows "pick (insert a I) (insert_index a' i) = pick I i" +proof (cases "i I" + by (simp add: Ik ik pick_in_set_le) + show "pick (insert a I) i < pick I i" + by (rule pick_insert2[OF a_notin_I _ a_def _ a'k], insert False, auto simp add: Ik ik) + fix y assume y: "y \ I \ pick (insert a I) i < y" + let ?xs = "sorted_list_of_set (insert a I)" + have "y \ set ?xs" using y by (metis fin_aI insertI2 set_sorted_list_of_set y) + from this obtain j where xs_j_y: "?xs ! j = y" and j: "j < length ?xs" + using in_set_conv_nth by metis + have ij: "i pick (insert a I) j" + by (metis Ik Suc_lessI card_infinite distinct_card distinct_sorted_list_of_set eq_iff + finite_insert ij ik j less_imp_le_nat not_less_zero pick_mono_le set_sorted_list_of_set) + also have "... = ?xs ! j" by (rule sorted_list_of_set_eq_pick[symmetric, OF j]) + also have "... = y" by (rule xs_j_y) + finally show "pick I i \ y" . + qed + finally show ?thesis unfolding insert_index_def using False by auto +qed + + +subsection\Start of the proof\ + +definition "strict_from_inj n f = (\i. if i\{0.. nat" + assumes "inj_on f {0.. {0.. {0.. f ` {0.. f ` {0.. strict_from_inj n f ` {0..)|f \. f \ {0.. {0.. (\i. i \ {0.. f i = i) + \ \ permutes {0.. {0.. {0.. (\i. i \ {0.. f i = i)} \ {\. \ permutes {0.. carrier_mat n m" + and B: "B \ carrier_mat m n" + shows "det (A*B) = det (mat\<^sub>r n n (\i. finsum_vec TYPE('a::comm_ring_1) n + (\k. B $$ (k, i) \\<^sub>v Matrix.col A k) {0..T \ carrier_mat m n" using A by auto + have BT: "B\<^sup>T \ carrier_mat n m" using B by auto + let ?f = "(\i. finsum_vec TYPE('a) n (\k. B\<^sup>T $$ (i, k) \\<^sub>v Matrix.row A\<^sup>T k) {0..k\{0..T $$ (i, k) \\<^sub>v row A\<^sup>T k) $ j)" + by (rule index_finsum_vec[OF _ j_n], auto simp add: A) + also have "... = (\k\{0..\<^sub>v col A k) $ j)" + proof (rule sum.cong, auto) + fix x assume x: "xT x = col A x" by (rule row_transpose, insert A x, auto) + have B_rw: "B\<^sup>T $$ (i,x) = B $$ (x, i)" + by (rule index_transpose_mat, insert x i B, auto) + have "(B\<^sup>T $$ (i, x) \\<^sub>v Matrix.row A\<^sup>T x) $v j = B\<^sup>T $$ (i, x) * Matrix.row A\<^sup>T x $v j" + by (rule index_smult_vec, insert A j_n, auto) + also have "... = B $$ (x, i) * col A x $v j" unfolding row_rw B_rw by simp + also have "... = (B $$ (x, i) \\<^sub>v col A x) $v j" + by (rule index_smult_vec[symmetric], insert A j_n, auto) + finally show " (B\<^sup>T $$ (i, x) \\<^sub>v Matrix.row A\<^sup>T x) $v j = (B $$ (x, i) \\<^sub>v col A x) $v j" . + qed + also have "... = ?g i $v j" + by (rule index_finsum_vec[symmetric, OF _ j_n], auto simp add: A) + also have "... = ?rhs $$ (i, j)" by (rule index_mat[symmetric], insert i j, auto) + finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" . + qed + have "det (A*B) = det (B\<^sup>T*A\<^sup>T)" + using det_transpose + by (metis A B Matrix.transpose_mult mult_carrier_mat) + also have "... = det (mat\<^sub>r n n (\i. finsum_vec TYPE('a) n (\k. B\<^sup>T $$ (i, k) \\<^sub>v Matrix.row A\<^sup>T k) {0..r n n (\i. finsum_vec TYPE('a) n (\k. B $$ (k, i) \\<^sub>v Matrix.col A k) {0.. carrier_mat n m" + and B: "B \ carrier_mat m n" + shows "det (A*B) = (\f | (\i\{0.. {0.. (\i. i \ {0.. f i = i). + (\i = 0..r n n (\i. col A (f i))))" +proof - + let ?V="{0..r n n (\i. B $$ (f i, i) \\<^sub>v col A (f i))) = + (prod (\i. B $$ (f i, i)) {0..r n n (\i. col A (f i)))" + if f: "(\i\{0.. {0.. (\i. i \ {0.. f i = i)" for f + by (rule det_rows_mul, insert A col_dim, auto) + have "det (A*B) = det (mat\<^sub>r n n (\i. finsum_vec TYPE('a::comm_ring_1) n (\k. B $$ (k, i) \\<^sub>v Matrix.col A k) ?U))" + by (rule det_mul_finsum_alt[OF A B]) + also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A) + also have "... = (\f\?F. prod (\i. B $$ (f i, i)) {0..r n n (\i. col A (f i))))" + using det_rw by auto + finally show ?thesis . +qed + +lemma det_cols_mul': + assumes A: "A \ carrier_mat n m" + and B: "B \ carrier_mat m n" + shows "det (A*B) = (\f | (\i\{0.. {0.. (\i. i \ {0.. f i = i). + (\i = 0..r n n (\i. row B (f i))))" +proof - + let ?F="{f. (\i\{0.. {0.. (\i. i \ {0.. f i = i)}" + have t: "A * B = (B\<^sup>T*A\<^sup>T)\<^sup>T" using transpose_mult[OF A B] transpose_transpose by metis + have "det (B\<^sup>T*A\<^sup>T) = (\f\?F. (\i = 0..T $$ (f i, i)) * det (mat\<^sub>r n n (\i. col B\<^sup>T (f i))))" + by (rule det_cols_mul, auto simp add: A B) + also have "... = (\f \?F. (\i = 0..r n n (\i. row B (f i))))" + proof (rule sum.cong, rule refl) + fix f assume f: "f \ ?F" + have "(\i = 0..T $$ (f i, i)) = (\i = 0.. {0..T $$ (f x, x) = A $$ (x, f x)" + by (rule index_transpose_mat(1), insert f A x, auto) + qed + moreover have "det (mat\<^sub>r n n (\i. col B\<^sup>T (f i))) = det (mat\<^sub>r n n (\i. row B (f i)))" + proof - + have row_eq_colT: "row B (f i) $v j = col B\<^sup>T (f i) $v j" if i: "i < n" and j: "j < n" for i j + proof - + have fi_m: "f i < m" using f i by auto + have "col B\<^sup>T (f i) $v j = B\<^sup>T $$(j, f i)" by (rule index_col, insert B fi_m j, auto) + also have "... = B $$ (f i, j)" using B fi_m j by auto + also have "... = row B (f i) $v j" by (rule index_row[symmetric], insert B fi_m j, auto) + finally show ?thesis .. + qed + show ?thesis by (rule arg_cong[of _ _ det], rule eq_matI, insert row_eq_colT, auto) + qed + ultimately show "(\i = 0..T $$ (f i, i)) * det (mat\<^sub>r n n (\i. col B\<^sup>T (f i))) = + (\i = 0..r n n (\i. row B (f i)))" by simp + qed + finally show ?thesis + by (metis (no_types, lifting) A B det_transpose transpose_mult mult_carrier_mat) +qed + +(*We need a more general version of this lemma*) +lemma + assumes F: "F= {f. f \ {0.. {0.. (\i. i \ {0.. f i = i)}" + and p: " \ permutes {0..f\F. (\i = 0.. i))) = (\f\F. (\i = 0.. \ = g \ \" + have "f x = g x" for x + proof (cases "x \ {0.. F" show "xa \ \ \ F" + unfolding o_def F + using F PiE p xa + by (auto, smt F atLeastLessThan_iff mem_Collect_eq p permutes_def xa) + show "\x\F. xa = x \ \" + proof (rule bexI[of _ "xa \ Hilbert_Choice.inv \"]) + show "xa = xa \ Hilbert_Choice.inv \ \ \" + using p by auto + show "xa \ Hilbert_Choice.inv \ \ F" + unfolding o_def F + using F PiE p xa + by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3)) + qed + qed + have prod_rw: "(\i = 0..i = 0.. i), \ i))" if "f\F" for f + using prod.permute[OF p] by auto + let ?g = "\f. (\i = 0.. i))" + have "(\f\F. (\i = 0..f\F. (\i = 0.. i), \ i)))" + using prod_rw by auto + also have "... = (\f\(?h`F). \i = 0.. i))" + using sum.reindex[OF inj_on_F, of ?g] unfolding hF by auto + also have "... = (\f\F. \i = 0.. i))" unfolding hF by auto + finally show ?thesis .. +qed + + +lemma detAB_Znm_aux: + assumes F: "F= {f. f \ {0.. {0.. (\i. i \ {0.. f i = i)}" + shows"(\\ | \ permutes {0..f\F. prod (\i. B $$ (f i, i)) {0.. * (\i = 0.. i, f i))))) + = (\\ | \ permutes {0..f\F. (\i = 0.. i)) + * (signof \ * (\i = 0..\ | \ permutes {0..f\F. prod (\i. B $$ (f i, i)) {0.. * (\i = 0.. i, f i))))) = + (\\ | \ permutes {0..f\F. signof \ * (\i = 0.. i, f i)))" + by (smt mult.left_commute prod.cong prod.distrib sum.cong) + also have "... = (\\ | \ permutes {0..f\F. signof (Hilbert_Choice.inv \) + * (\i = 0.. i, f i)))" + by (rule sum_permutations_inverse) + also have "... = (\\ | \ permutes {0..f\F. signof (Hilbert_Choice.inv \) + * (\i = 0.. i), (\ i)) * A $$ (Hilbert_Choice.inv \ (\ i), f (\ i))))" + proof (rule sum.cong) + fix x assume x: "x \ {\. \ permutes {0..i = 0..i = 0.. F" for f + using prod.permute[OF p] by auto + then show "(\f\F. signof ?inv_x * (\i = 0..f\F. signof ?inv_x * (\i = 0..\ | \ permutes {0..f\F. signof \ + * (\i = 0.. i), (\ i)) * A $$ (i, f (\ i))))" + by (rule sum.cong, auto, rule sum.cong, auto) + (metis (no_types, lifting) finite_atLeastLessThan signof_inv) + also have "... = (\\ | \ permutes {0..f\F. signof \ + * (\i = 0.. i)) * A $$ (i, f i)))" + proof (rule sum.cong) + fix \ assume p: "\ \ {\. \ permutes {0.. permutes {0.. ?inv_pi = g \ ?inv_pi" + have "f x = g x" for x + proof (cases "x \ {0.. F" show "xa \ ?inv_pi \ F" + unfolding o_def F + using F PiE p xa + by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3)) + show "\x\F. xa = x \ ?inv_pi" + proof (rule bexI[of _ "xa \ \"]) + show "xa = xa \ \ \ Hilbert_Choice.inv \ " + using p by auto + show "xa \ \ \ F" + unfolding o_def F + using F PiE p xa + by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3)) + qed + qed + let ?g = "\f. signof \ * (\i = 0.. i), \ i) * A $$ (i, f (\ i)))" + show "(\f\F. signof \ * (\i = 0.. i), \ i) * A $$ (i, f (\ i)))) = + (\f\F. signof \ * (\i = 0.. i) * A $$ (i, f i)))" + using sum.reindex[OF inj_on_F, of "?g"] p unfolding hF unfolding o_def by auto + qed (simp) + also have "... = (\\ | \ permutes {0..f\F. (\i = 0.. i)) + * (signof \ * (\i = 0.. carrier_mat n m" + and B: "B \ carrier_mat m n" + shows "det (A*B) = (\(f, \)\Z n m. signof \ * (\i = 0.. i)))" +proof - + let ?V="{0.. {0.. {0.. (\i. i \ {0.. f i = i)}" by auto + have det_rw: "det (mat\<^sub>r n n (\i. B $$ (f i, i) \\<^sub>v col A (f i))) = + (prod (\i. B $$ (f i, i)) {0..r n n (\i. col A (f i)))" + if f: "(\i\{0.. {0.. (\i. i \ {0.. f i = i)" for f + by (rule det_rows_mul, insert A col_dim, auto) + have det_rw2: "det (mat\<^sub>r n n (\i. col A (f i))) + = (\\ | \ permutes {0.. * (\i = 0.. i, f i)))" + if f: "f \ ?F" for f + proof (unfold Determinant.det_def, auto, rule sum.cong, auto) + fix x assume x: "x permutes {0..i = 0..i = 0.. {0..i = 0..i = 0..r n n (\i. finsum_vec TYPE('a::comm_ring_1) n + (\k. B $$ (k, i) \\<^sub>v Matrix.col A k) {0..f\?F. prod (\i. B $$ (f i, i)) {0..r n n (\i. col A (f i))))" + using det_rw by auto + also have "... = (\f\?F. prod (\i. B $$ (f i, i)) {0..\ | \ permutes {0.. * (\i = 0.. i, f (i)))))" + by (rule sum.cong, auto simp add: det_rw2) + also have "... = + (\f\?F. \\ | \ permutes {0..i. B $$ (f i, i)) {0.. * (\i = 0.. i, f (i)))))" + by (simp add: mult_hom.hom_sum) + also have "... = (\\ | \ permutes {0..f\?F.prod (\i. B $$ (f i, i)) {0.. * (\i = 0.. i, f i))))" + by (rule VS_Connect.class_semiring.finsum_finsum_swap, + insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto) + thm detAB_Znm_aux + also have "... = (\\ | \ permutes {0..f\?F. (\i = 0.. i)) + * (signof \ * (\i = 0..f\?F.\\ | \ permutes {0..i = 0.. i)) + * (signof \ * (\i = 0..f\?F.\\ | \ permutes {0.. + * (\i = 0.. i)))" + unfolding prod.distrib by (rule sum.cong, auto, rule sum.cong, auto) + also have "... = sum (\(f,\). (signof \) + * (prod (\i. A$$(i,f i) * B $$ (f i, \ i)) {0.. carrier_mat n m" + and B: "B \ carrier_mat m n" +begin + +private definition "Z_inj = ({f. f \ {0.. {0.. (\i. i \ {0.. f i = i) + \ inj_on f {0.. {\. \ permutes {0.. {0.. {0.. (\i. i \ {0.. f i = i) + \ \ inj_on f {0.. {\. \ permutes {0.. {0.. {0.. (\i. i \ {0.. f i = i) + \ strict_mono_on f {0.. {\. \ permutes {0.. {0.. {0.. (\i. i \ {0.. f i = i) + \ \ strict_mono_on f {0.. {\. \ permutes {0.. + = (signof \) * (prod (\i. A$$(i,f i) * B $$ (f i, \ i)) {0.. {0.. {0.. (\i. i \ {0.. f i = i) + \ inj_on f {0.. (f`{0.. {\. \ permutes {0.. {0.. {0.. (\i. i \ {0.. f i = i) \ strict_mono_on f {0.. {0.. {0.. (\i. i \ {0.. f i = i) \ inj_on f {0.. {0.. {0.. (\i. i \ {0.. f i = i) \ \ inj_on f {0.. {0.. {0.. (\i. i \ {0.. f i = i)}" + +text\The Cauchy--Binet formula is proven in \url{https://core.ac.uk/download/pdf/82475020.pdf} + In that work, they define @{text "\ \ inv \ \ \"}. I had problems following this proof + in Isabelle, since I was demanded to show that such permutations commute, which is false. + It is a notation problem of the @{text "\"} operator, the author means @{text "\ \ \ \ inv \"} using + the Isabelle notation (i.e., @{text "\ x = \ ((inv \) x)"}). +\ + +lemma step_weight: + fixes \ \ + defines "\ \ \ \ Hilbert_Choice.inv \" + assumes f_inj: "f \ F_inj" and gF: "g \ F" and pi: "\ permutes {0.. permutes {0..x \ {0.. x)" +shows "weight f \ = (signof \) * (\i = 0.. i))) + * (signof \) * (\i = 0.. i))" +proof - + let ?A = "(\i = 0.. i))) " + let ?B = "(\i = 0.. i))" + have sigma: "\ permutes {0.._def + by (rule permutes_compose[OF permutes_inv[OF phi] pi]) + have A_rw: "?A = (\i = 0..i = 0.. i), \ (\ i)))" + by (rule prod.permute[unfolded o_def, OF phi]) + also have "... = (\i = 0.. i))" + using fg_phi + unfolding \_def unfolding o_def unfolding permutes_inverses(2)[OF phi] by auto + finally have B_rw: "?B = (\i = 0.. i))" . + have "(signof \) * ?A * (signof \) * ?B = (signof \) * (signof \) * ?A * ?B" by auto + also have "... = signof (\ \ \) * ?A * ?B" unfolding signof_compose[OF phi sigma] by simp + also have "... = signof \ * ?A * ?B" + by (metis (no_types, lifting) \_def mult.commute o_inv_o_cancel permutes_inj + phi sigma signof_compose) + also have "... = signof \ * (\i = 0..i = 0.. i))" + using A_rw B_rw by auto + also have "... = signof \ * (\i = 0.. i))" by auto + also have "... = weight f \" unfolding weight_def by simp + finally show ?thesis .. +qed + + +lemma Z_good_fun_alt_sum: + fixes g + defines "Z_good_fun \ {f. f \ {0.. {0.. (\i. i \ {0.. f i = i) + \ inj_on f {0.. (f`{0.. F_inj" + shows "(\f\Z_good_fun. P f)= (\\\{\. \ permutes {0.. \))" +proof - + let ?f = "\\. g \ \" + let ?P = "{\. \ permutes {0.. i < n" + hence "xa i = i" unfolding permutes_def by auto + thus "g (xa i) = i" using g i_ge_n unfolding F_inj_def by auto + next + fix xa assume "xa permutes {0.. xa) {0.. xb assume "\ permutes {0.. (\x. g (\ x)) ` {0.. {0.. {0..i. \ i < n \ x i = i" + and inj_on_x: "inj_on x {0.. = "\i. if i x i = g j) else i" + show "x \ (\) g ` {\. \ permutes {0..], rule conjI) + have "?\ i = i" if i: "i \ {0..!j. ?\ j = i" for i + proof (cases "i x a = g j) = i" + proof (rule theI2) + show "i < n \ x a = g i" using xa_gi True by auto + fix xa assume "xa < n \ x a = g xa" thus "xa = i" + by (metis (mono_tags, lifting) F_inj_def True atLeast0LessThan + g inj_onD lessThan_iff mem_Collect_eq xa_gi) + thus "xa = i" . + qed + thus ta: "?\ a = i" using a by auto + fix j assume tj: "?\ j = i" + show "j = a" + proof (cases "j x j = g ja) = i" using tj True by auto + have "?P (THE ja. ?P ja)" + proof (rule theI) + show "b < n \ x j = g b" using xj_gb b by auto + fix xa assume "xa < n \ x j = g xa" thus "xa = b" + by (metis (mono_tags, lifting) F_inj_def b atLeast0LessThan + g inj_onD lessThan_iff mem_Collect_eq xj_gb) + qed + hence "x j = g i" unfolding the_ji by auto + hence "x j = x a" using xa_gi by auto + then show ?thesis using inj_on_x a True unfolding inj_on_def by auto + next + case False + then show ?thesis using tj True by auto + qed + qed + next + case False note i_ge_n = False + show ?thesis + proof (rule ex1I[of _ i]) + show "?\ i = i" using False by simp + fix j assume tj: "?\ j = i" + show "j = i" + proof (cases "j x j = g ja) < n" + proof (rule theI2) + show "a < n \ x j = g a" using xj_ga a by auto + fix xa assume a1: "xa < n \ x j = g xa" thus "xa = a" + using F_inj_def a atLeast0LessThan g inj_on_eq_iff xj_ga by fastforce + show "xa < n" by (simp add: a1) + qed + then show ?thesis using tj i_ge_n by auto + next + case False + then show ?thesis using tj by auto + qed + qed + qed + ultimately show "?\ permutes {0.. ?\" + proof - + have "x xa = g (THE j. j < n \ x xa = g j)" if xa: "xa < n" for xa + proof - + obtain c where c: "c < n" and xxa_gc: "x xa = g c" + by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff xa xg) + show ?thesis + proof (rule theI2) + show c1: "c < n \ x xa = g c" using c xxa_gc by auto + fix xb assume c2: "xb < n \ x xa = g xb" thus "xb = c" + by (metis (mono_tags, lifting) F_inj_def c1 atLeast0LessThan + g inj_onD lessThan_iff mem_Collect_eq) + show "x xa = g xb" using c1 c2 by simp + qed + qed + moreover have "x xa = g xa" if xa: "\ xa < n" for xa + using g x1 x2 xa unfolding F_inj_def by simp + ultimately show ?thesis unfolding o_def fun_eq_iff by auto + qed + qed + qed + have inj: "inj_on ?f ?P" + proof (rule inj_onI) + fix x y assume x: "x \ ?P" and y: "y \ ?P" and gx_gy: "g \ x = g \ y" + have "x i = y i" for i + proof (cases "i {0.. {0..f\Z_good_fun. P f) = (\f\?f`?P. P f)" using fP by simp + also have "... = sum (P \ (\) g) {\. \ permutes {0..\ | \ permutes {0.. \))" by auto + finally show ?thesis . +qed + + +lemma F_injI: + assumes "f \ {0.. {0..i. i \ {0.. f i = i)" and "inj_on f {0.. F_inj" using assms unfolding F_inj_def by simp + +lemma F_inj_composition_permutation: + assumes phi: "\ permutes {0.. F_inj" + shows "g \ \ \ F_inj" +proof (rule F_injI) + show "g \ \ \ {0.. {0..i. i \ {0.. (g \ \) i = i" + using g phi unfolding permutes_def F_inj_def by simp + show "inj_on (g \ \) {0.. F_strict" + shows "f \ F_inj" + using f strict_mono_on_imp_inj_on + unfolding F_strict_def F_inj_def by auto + + +lemma one_step: + assumes g1: "g \ F_strict" + shows "det (submatrix A UNIV (g`{0..(x, y) \ Z_good g. weight x y)" (is "?lhs = ?rhs") +proof - + define Z_good_fun where "Z_good_fun = {f. f \ {0.. {0.. (\i. i \ {0.. f i = i) + \ inj_on f {0.. (f`{0.. F_inj" by (rule F_strict_imp_F_inj[OF g1]) + have detA: "(\\\{\. \ permutes {0.. * (\i = 0.. i)))) + = det (submatrix A UNIV (g`{0.. j \ g ` {0.. g ` {0.. j \ g ` {0.. carrier_mat n n" + unfolding submatrix_def card_J using A by auto + have "det (submatrix A UNIV (g`{0..p | p permutes {0..i = 0..\\{\. \ permutes {0.. * (\i = 0.. i))))" + proof (rule sum.cong) + fix x assume x: "x \ {\. \ permutes {0..i = 0..i = 0.. {0.. (g ` {0..i = 0..i = 0..\ \ ?Perm. signof (\ \ ?inv \) * (\i = 0.. \ ?inv \) i))) + = (\\ \ ?Perm. signof (\) * (\i = 0.. i)))" + if phi: "\ permutes {0.. + proof - + let ?h="\\. \ \ ?inv \" + let ?g = "\\. signof (\) * (\i = 0.. i))" + have "?h`?Perm = ?Perm" + proof - + have "\ \ ?inv \ permutes {0.. permutes {0.. + using permutes_compose permutes_inv phi that by blast + moreover have "x \ (\\. \ \ ?inv \) ` ?Perm" if "x permutes {0.. \ permutes {0.. \ \ ?inv \" using phi by auto + ultimately show ?thesis unfolding image_def by auto + qed + ultimately show ?thesis by auto + qed + hence "(\\ \ ?Perm. ?g \) = (\\ \ ?h`?Perm. ?g \)" by simp + also have "... = sum (?g \ ?h) ?Perm" + proof (rule sum.reindex) + show "inj_on (\\. \ \ ?inv \) {\. \ permutes {0..\ \ ?Perm. signof (\ \ ?inv \) * (\i = 0.. \ ?inv \) i)))" + unfolding o_def by auto + finally show ?thesis by simp + qed + + have detB: "det (submatrix B (g`{0..\ \ ?Perm. signof \ * (\i = 0.. i)))" + proof - + have "{i. i < dim_row B \ i \ g ` {0.. g ` {0.. j \ g ` {0.. carrier_mat n n" + unfolding submatrix_def using card_I B by auto + have "det (submatrix B (g`{0..p \ ?Perm. signof p + * (\i=0..\ \ ?Perm. signof \ * (\i = 0.. i)))" + proof (rule sum.cong, rule refl) + fix x assume x: "x \ {\. \ permutes {0..i=0..i=0.. {0.. (g ` {0..i = 0..i = 0..f\Z_good_fun. \\\?Perm. weight f \)" + unfolding Z_good_def sum.cartesian_product Z_good_fun_def by blast + also have "... = (\\\{\. \ permutes {0.. \))" unfolding Z_good_fun_def + by (rule Z_good_fun_alt_sum[OF g]) + also have "... = (\\\{\. \ permutes {0..\\{\. \ permutes {0.. * (\i = 0.. i))) * signof (\ \ ?inv \) + * (\i = 0.. \ ?inv \) i)))" + proof (rule sum.cong, simp, rule sum.cong, simp) + fix \ \ assume phi: "\ \ ?Perm" and pi: "\ \ ?Perm" + show "weight (g \ \) \ = signof \ * (\i = 0.. i))) * + signof (\ \ ?inv \) * (\i = 0.. \ ?inv \) i))" + proof (rule step_weight) + show "g \ \ \ F_inj" by (rule F_inj_composition_permutation[OF _ g], insert phi, auto) + show "g \ F" using g unfolding F_def F_inj_def by simp + qed (insert phi pi, auto) + qed + also have "... = (\\\{\. \ permutes {0.. * (\i = 0.. i))) * + (\\ | \ permutes {0.. \ ?inv \) * (\i = 0.. \ ?inv \) i))))" + by (metis (mono_tags, lifting) Groups.mult_ac(1) semiring_0_class.sum_distrib_left sum.cong) + also have "... = (\\ \ ?Perm. signof \ * (\i = 0.. i))) * + (\\ \ ?Perm. signof \ * (\i = 0.. i))))" using detB_rw by auto + also have "... = (\\ \ ?Perm. signof \ * (\i = 0.. i)))) * + (\\ \ ?Perm. signof \ * (\i = 0.. i)))" + by (simp add: semiring_0_class.sum_distrib_right) + also have "... = ?lhs" unfolding detA detB .. + finally show ?thesis .. +qed + + +lemma gather_by_strictness: +"sum (\g. sum (\(f,\). weight f \) (Z_good g)) F_strict + = sum (\g. det (submatrix A UNIV (g`{0.. F_strict" + show "(\(x, y)\Z_good f. weight x y) + = det (submatrix A UNIV (f ` {0..i\{0.. {0.. (\i. i \ {0.. f i = i)} = ?B" by auto + have "?A\?B" by auto + moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto + ultimately show "finite ?A" using rev_finite_subset by blast + show "finite {\. \ permutes {0..i\{0.. {0.. (\i. i \ {0.. f i = i)} = ?B" by auto + have "?A\?B" by auto + moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto + ultimately show "finite ?A" using rev_finite_subset by blast + show "finite {\. \ permutes {0..i\{0.. {0.. (\i. i \ {0.. f i = i)} = ?B" by auto + have "?A\?B" by auto + moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto + ultimately show "finite ?A" using rev_finite_subset by blast + show "finite {\. \ permutes {0..i\{0.. {0.. (\i. i \ {0.. f i = i)} = ?B" by auto + have "?A\?B" by auto + moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto + ultimately show "finite F_inj" unfolding F_inj_def using rev_finite_subset by blast +qed + +lemma finite_F_strict[simp]: "finite F_strict" +proof - + have finN: "finite {0..i\{0.. {0.. (\i. i \ {0.. f i = i)} = ?B" by auto + have "?A\?B" by auto + moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto + ultimately show "finite F_strict" unfolding F_strict_def using rev_finite_subset by blast +qed + +lemma nth_strict_mono: + fixes f::"nat \ nat" + assumes strictf: "strict_mono f" and i: "i ?I. a < f i} = i" + using i + proof (induct i) + case 0 + then show ?case + by (auto simp add: strict_mono_less strictf) + next + case (Suc i) + have i: "i < n" using Suc.prems by auto + let ?J'="{a \ f ` {0.. f i" and 2: "f xa < f (Suc i)" + show "f xa < f i" + using 1 2 not_less_less_Suc_eq strict_mono_less strictf by fastforce + next + fix xa assume "f xa < f i" thus "f xa < f (Suc i)" + using less_SucI strict_mono_less strictf by blast + next + show "f i \ f ` {0.. ?I. a < f i})" unfolding card_eq by simp + also have "... = f i" by (rule pick_card_in_set, simp add: i) + finally show ?thesis .. +qed + +lemma nth_strict_mono_on: + fixes f::"nat \ nat" + assumes strictf: "strict_mono_on f {0.. ?I. a < f i} = i" + using i + proof (induct i) + case 0 + then show ?case + by (auto, metis (no_types, lifting) atLeast0LessThan lessThan_iff less_Suc_eq + not_less0 not_less_eq strict_mono_on_def strictf) + next + case (Suc i) + have i: "i < n" using Suc.prems by auto + let ?J'="{a \ f ` {0.. f i" and 2: "f xa < f (Suc i)" and 3: "xa < n" + show "f xa < f i" + by (metis (full_types) 1 2 3 antisym_conv3 atLeast0LessThan i lessThan_iff + less_SucE order.asym strict_mono_onD strictf) + next + fix xa assume "f xa < f i" and "xa < n" thus "f xa < f (Suc i)" + using less_SucI strictf + by (metis (no_types, lifting) Suc.prems atLeast0LessThan + lessI lessThan_iff less_trans strict_mono_onD) + next + show "f i \ f ` {0.. ?I. a < f i})" unfolding card_eq by simp + also have "... = f i" by (rule pick_card_in_set, simp add: i) + finally show ?thesis .. +qed + +lemma strict_fun_eq: + assumes f: "f \ F_strict" and g: "g \ F_strict" and fg: "f`{0.. F_inj" + shows "strict_from_inj n f \ F" +proof - + { + fix x assume x: "x < n" + have inj_on: "inj_on f {0.. a \ f ` {0.. a \ f ` {0.. F_strict" + if xa: "xa \ F_inj" for xa +proof - + have "strict_mono_on (strict_from_inj n xa) {0.. F_inj" + shows "strict_from_inj n f ` {0.. a \ f ` {0.. a \ f ` {0.. f ` {0..card (f ` {0.. xa) + finally show "strict_from_inj n f xa \ f ` {0.. strict_from_inj n f ` {0.. F_strict" + shows "Z_good g = {x \ F_inj. strict_from_inj n x = g} \ {\. \ permutes {0.. {0.. {0.. (\i. i \ {0.. f i = i) + \ inj_on f {0.. (f`{0.. F_inj. strict_from_inj n x = g}" + proof (auto) + fix f assume f: "f \ Z_good_fun" thus f_inj: "f \ F_inj" unfolding F_inj_def Z_good_fun_def by auto + show "strict_from_inj n f = g" + proof (rule strict_fun_eq[OF _ g]) + show "strict_from_inj n f ` {0.. F_strict" + using F_strict_def f_inj strict_from_inj_F_strict by blast + qed + next + fix f assume f_inj: "f \ F_inj" and g_strict_f: "g = strict_from_inj n f" + have "f xa \ g ` {0.. f ` {0.. Z_good_fun" + using f_inj g_strict_f unfolding Z_good_fun_def F_inj_def + by auto + qed + thus ?thesis unfolding Z_good_fun_def Z_good_def by simp +qed + + +lemma weight_0: "(\(f, \) \ Z_not_inj. weight f \) = 0" +proof - + let ?F="{f. (\i\{0.. {0.. (\i. i \ {0.. f i = i)}" + let ?Perm = "{\. \ permutes {0..(f, \)\Z_not_inj. weight f \) + = (\f \ F_not_inj. (\i = 0..r n n (\i. row B (f i))))" + proof - + have dim_row_rw: "dim_row (mat\<^sub>r n n (\i. col A (f i))) = n" for f by auto + have dim_row_rw2: "dim_row (mat\<^sub>r n n (\i. Matrix.row B (f i))) = n" for f by auto + have prod_rw: "(\i = 0.. i)) = (\i = 0.. i)" + if f: "f \ F_not_inj" and pi: "\ \ ?Perm" for f \ + proof (rule prod.cong, rule refl) + fix x assume x: "x \ {0.. x < dim_col B" using x pi B by auto + ultimately show "B $$ (f x, \ x) = Matrix.row B (f x) $v \ x" by (rule index_row[symmetric]) + qed + have sum_rw: "(\\ | \ permutes {0.. * (\i = 0.. i))) + = det (mat\<^sub>r n n (\i. row B (f i)))" if f: "f \ F_not_inj" for f + unfolding Determinant.det_def using dim_row_rw2 prod_rw f by auto + have "(\(f, \)\Z_not_inj. weight f \) = (\f\F_not_inj.\\ \ ?Perm. weight f \)" + unfolding Z_not_inj_def unfolding sum.cartesian_product + unfolding F_not_inj_def by simp + also have "... = (\f\F_not_inj. \\ | \ permutes {0.. + * (\i = 0.. i)))" + unfolding weight_def by simp + also have "... = (\f\F_not_inj. (\i = 0..\ | \ permutes {0.. * (\i = 0.. i))))" + by (rule sum.cong, rule refl, auto) + (metis (no_types, lifting) mult.left_commute mult_hom.hom_sum sum.cong) + also have "... = (\f \ F_not_inj. (\i = 0..r n n (\i. row B (f i))))" using sum_rw by auto + finally show ?thesis by auto + qed + also have "... = 0" + by (rule sum.neutral, insert det_not_inj_on[of _ n B], auto simp add: F_not_inj_def) + finally show ?thesis . +qed + +subsection \Final theorem\ + +lemma Cauchy_Binet1: + shows "det (A*B) = + sum (\f. det (submatrix A UNIV (f`{0..(f, \) \ Z_not_inj. weight f \) = 0" by (rule weight_0) + let ?f = "strict_from_inj n" + have sum_rw: "sum g F_inj = (\y \ F_strict. sum g {x \ F_inj. ?f x = y})" for g + by (rule sum.group[symmetric], insert strict_from_inj_F_strict, auto) + have Z_Union: "Z_inj \ Z_not_inj = Z n m" + unfolding Z_def Z_not_inj_def Z_inj_def by auto + have Z_Inter: "Z_inj \ Z_not_inj = {}" + unfolding Z_def Z_not_inj_def Z_inj_def by auto + have "det (A*B) = (\(f, \)\Z n m. weight f \)" + using detAB_Znm[OF A B] unfolding weight_def by auto + also have "... = (\(f, \)\Z_inj. weight f \) + (\(f, \)\Z_not_inj. weight f \)" + by (metis Z_Inter Z_Union finite_Un finite_Znm sum.union_disjoint) + also have "... = (\(f, \)\Z_inj. weight f \)" using sum0 by force + also have "... = (\f \ F_inj. \\\{\. \ permutes {0..)" + unfolding Z_inj_def unfolding F_inj_def sum.cartesian_product .. + also have "... = (\y\F_strict. \f\{x \ F_inj. strict_from_inj n x = y}. + sum (weight f) {\. \ permutes {0..y\F_strict. \(f,\)\({x \ F_inj. strict_from_inj n x = y} + \ {\. \ permutes {0..)" + unfolding F_inj_def sum.cartesian_product .. + also have "... = sum (\g. sum (\(f,\). weight f \) (Z_good g)) F_strict" + using Z_good_alt by auto + also have "... = ?rhs" unfolding gather_by_strictness by simp + finally show ?thesis . +qed + + +lemma Cauchy_Binet: + "det (A*B) = (\I\{I. I\{0.. card I=n}. det (submatrix A UNIV I) * det (submatrix B I UNIV))" +proof - + let ?f="(\I. (\i. if i ?setI" and J: "J \ ?setI" and fI_fJ: "?f I = ?f J" + have "x \ J" if x: "x \ I" for x + by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq + sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x) + moreover have "x \ I" if x: "x \ J" for x + by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq + sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x) + ultimately show "I = J" by auto + qed + have rw: "?f I ` {0.. ?setI" for I + proof - + have "sorted_list_of_set I ! xa \ I" if "xa < n" for xa + by (metis (mono_tags, lifting) I distinct_card distinct_sorted_list_of_set mem_Collect_eq + nth_mem set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite that) + moreover have "\xa\{0..I" for x + by (metis (full_types) x I atLeast0LessThan distinct_card in_set_conv_nth mem_Collect_eq + lessThan_iff sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite) + ultimately show ?thesis unfolding image_def by auto + qed + have f_setI: "?f` ?setI = F_strict" + proof - + have "sorted_list_of_set I ! xa < m" if I: "I \ {0..xa < card I\ atLeast0LessThan distinct_card finite_atLeastLessThan lessThan_iff + pick_in_set_le rev_finite_subset sorted_list_of_set(1) + sorted_list_of_set(3) sorted_list_of_set_eq_pick subsetCE) + moreover have "strict_mono_on (\i. if i < card I then sorted_list_of_set I ! i else i) {0.. {0..I \ {0.. atLeastLessThan_iff distinct_card finite_atLeastLessThan pick_mono_le + rev_finite_subset sorted_list_of_set(1) sorted_list_of_set(3) + sorted_list_of_set_eq_pick strict_mono_on_def) + moreover have "x \ ?f ` {I. I \ {0.. card I = n}" + if x1: "x \ {0.. {0..i. \ i < n \ x i = i" + and s: "strict_mono_on x {0..i. if i < n then sorted_list_of_set (x ` {0..f. det (submatrix A UNIV (f ` {0.. ?f) {I. I \ {0.. card I = n}" + unfolding Cauchy_Binet1 f_setI[symmetric] by (rule sum.reindex[OF inj_on]) + also have "... = (\I\{I. I\{0.. card I=n}.det(submatrix A UNIV I)*det(submatrix B I UNIV))" + by (rule sum.cong, insert rw, auto) + finally show ?thesis . +qed +end + +end diff --git a/thys/Smith_Normal_Form/Cauchy_Binet_HOL_Analysis.thy b/thys/Smith_Normal_Form/Cauchy_Binet_HOL_Analysis.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Cauchy_Binet_HOL_Analysis.thy @@ -0,0 +1,119 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \The Cauchy--Binet formula in HOL Analysis\ + +theory Cauchy_Binet_HOL_Analysis + imports + Cauchy_Binet + Perron_Frobenius.HMA_Connect +begin + +subsection \Definition of submatrices in HOL Analysis\ + +definition submatrix_hma :: "'a^'nc^'nr\nat set\nat set\('a^'nc2^'nr2)" + where "submatrix_hma A I J = (\ a b. A $h (from_nat (pick I (to_nat a))) $h (from_nat (pick J (to_nat b))))" + +context includes lifting_syntax +begin + +context + fixes I::"nat set" and J::"nat set" + assumes I: "card {i. i < CARD('nr::finite) \ i \ I} = CARD('nr2::finite)" + assumes J: "card {i. i < CARD('nc::finite) \ i \ J} = CARD('nc2::finite)" +begin + +lemma HMA_submatrix[transfer_rule]: "(HMA_M ===> HMA_M) (\A. submatrix A I J) + ((\A. submatrix_hma A I J):: 'a^ 'nc ^ 'nr \ 'a ^ 'nc2 ^ 'nr2)" +proof (intro rel_funI, goal_cases) + case (1 A B) + note relAB[transfer_rule] = this + show ?case unfolding HMA_M_def + proof (rule eq_matI, auto) + show "dim_row (submatrix A I J) = CARD('nr2)" + unfolding submatrix_def + using I dim_row_transfer_rule relAB by force + show "dim_col (submatrix A I J) = CARD('nc2)" + unfolding submatrix_def + using J dim_col_transfer_rule relAB by force + let ?B="(submatrix_hma B I J)::'a ^ 'nc2 ^ 'nr2" + fix i j assume i: "i < CARD('nr2)" and + j: "j < CARD('nc2)" + have i2: "i < card {i. i < dim_row A \ i \ I}" + using I dim_row_transfer_rule i relAB by fastforce + have j2: "j < card {j. j < dim_col A \ j \ J}" + using J dim_col_transfer_rule j relAB by fastforce + let ?i = "(from_nat (pick I i))::'nr" + let ?j = "(from_nat (pick J j))::'nc" + let ?i' = "Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2)" + let ?j' = "Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)" + have i': "?i' = i" by (rule to_nat_from_nat_id[OF i]) + have j': "?j' = j" by (rule to_nat_from_nat_id[OF j]) + let ?f = "(\(i, j). + B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h + Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2))))" + have [transfer_rule]: "HMA_I (pick I i) ?i" + by (simp add: Bij_Nat.to_nat_from_nat_id I i pick_le HMA_I_def) + have [transfer_rule]: "HMA_I (pick J j) ?j" + by (simp add: Bij_Nat.to_nat_from_nat_id J j pick_le HMA_I_def) + have "submatrix A I J $$ (i, j) = A $$ (pick I i, pick J j)" by (rule submatrix_index[OF i2 j2]) + also have "... = index_hma B ?i ?j" by (transfer, simp) + also have "... = B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h + Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)))" + unfolding i' j' index_hma_def by auto + also have "... = ?f (i,j)" by auto + also have "... = Matrix.mat CARD('nr2) CARD('nc2) ?f $$ (i, j)" + by (rule index_mat[symmetric, OF i j]) + also have "... = from_hma\<^sub>m ?B $$ (i, j)" + unfolding from_hma\<^sub>m_def submatrix_hma_def by auto + finally show "submatrix A I J $$ (i, j) = from_hma\<^sub>m ?B $$ (i, j)" . + qed +qed + +end +end + + +subsection \Transferring the proof from JNF to HOL Analysis\ + +lemma Cauchy_Binet_HOL_Analysis: + fixes A::"'a::comm_ring_1^'m^'n" and B::"'a^'n^'m" + shows "Determinants.det (A**B) = (\I\{I. I\{0.. card I=nrows A}. + Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) * + Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n))" +proof - + let ?A = "(from_hma\<^sub>m A)" + let ?B = "(from_hma\<^sub>m B)" + have relA[transfer_rule]: "HMA_M ?A A" unfolding HMA_M_def by simp + have relB[transfer_rule]: "HMA_M ?B B" unfolding HMA_M_def by simp + have "(\I\{I. I\{0.. card I = nrows A}. + Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) * + Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n)) = + (\I\{I. I\{0.. card I=nrows A}. det (submatrix ?A UNIV I) + * det (submatrix ?B I UNIV))" + proof (rule sum.cong) + fix I assume I: "I \{I. I\{0.. card I=nrows A}" + let ?sub_A= "((submatrix_hma A UNIV I)::'a^'n^'n)" + let ?sub_B= "((submatrix_hma B I UNIV)::'a^'n^'n)" + have c1: "card {i. i < CARD('n) \ i \ UNIV} = CARD('n)" using I by auto + have c2: "card {i. i < CARD('m) \ i \ I} = CARD('n)" + proof - + have "I = {i. i < CARD('m) \ i \ I}" using I unfolding nrows_def ncols_def by auto + thus ?thesis using I nrows_def by auto + qed + have [transfer_rule]: "HMA_M (submatrix ?A UNIV I) ?sub_A" + using HMA_submatrix[OF c1 c2] relA unfolding rel_fun_def by auto + have [transfer_rule]: "HMA_M (submatrix ?B I UNIV) ?sub_B" + using HMA_submatrix[OF c2 c1] relB unfolding rel_fun_def by auto + show "Determinants.det ?sub_A * Determinants.det ?sub_B + = det (submatrix ?A UNIV I) * det (submatrix ?B I UNIV)" by (transfer', auto) + qed (auto) + also have "... = det (?A*?B)" + by (rule Cauchy_Binet[symmetric], unfold nrows_def ncols_def, auto) + also have "... = Determinants.det (A**B)" by (transfer', auto) + finally show ?thesis .. +qed + +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/Diagonal_To_Smith.thy b/thys/Smith_Normal_Form/Diagonal_To_Smith.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Diagonal_To_Smith.thy @@ -0,0 +1,1895 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Algorithm to transform a diagonal matrix into its Smith normal form\ + +theory Diagonal_To_Smith + imports Hermite.Hermite + "HOL-Types_To_Sets.Types_To_Sets" + Smith_Normal_Form +begin + + +(*Move this theorem:*) +lemma invertible_mat_1: "invertible (mat (1::'a::comm_ring_1))" + unfolding invertible_iff_is_unit by simp + +subsection \Implementation of the algorithm\ + +type_synonym 'a bezout = "'a \ 'a \ 'a \ 'a \ 'a \ 'a \ 'a" + +hide_const Countable.from_nat +hide_const Countable.to_nat + +text \The algorithm is based on the one presented by Bradley in his article entitled + ``Algorithms for Hermite and Smith normal matrices and linear diophantine equations''. + Some improvements have been introduced to get a general version for any matrix (including + non-square and singular ones).\ + +text \I also introduced another improvement: the element in the position j does not need +to be checked each time, since the element $A_{ii}$ will already divide $A_{jj}$ (where $j \le k$). +The gcd will be placed in $A_{ii}$.\ + + +(*This version is a valid implementation and permits the formalization, + but it would not be executable due to the abstraction*) + +(* +primrec diagonal_to_Smith_i :: "nat list \ 'a:: {gcd,divide}^'n::mod_type^'n::mod_type \ 'n::mod_type \ 'a^'n::mod_type^'n::mod_type" + where +"diagonal_to_Smith_i [] A i = A" | +"diagonal_to_Smith_i (j#xs) A i = ( + if A $ i $ i dvd A $ (from_nat j) $ (from_nat j) then diagonal_to_Smith_i xs A i (*If it divides, then we proceed.*) + else + let c = gcd (A$i$i) (A$(from_nat j)$(from_nat j)); + A' = (\ a b. if a = i \ b = i then c else + if a = from_nat j \ b = from_nat j + then A$ i $ i * (A $ (from_nat j) $ (from_nat j) div c) else A $ a $ b) + in diagonal_to_Smith_i xs A' i (*We do the step and proceed*) + ) + " +*) + +text \This function transforms the element $A_{jj}$ in order to be divisible by $A_{ii}$ +(and it changes $A_{ii}$ as well). + +The use of @{text "from_nat"} and @{text "from_nat"} is mandatory since the same +index $i$ cannot be used for both rows +and columns at the same time, since they could have different type, concretely, +when the matrix is rectangular.\ + +text\The following definition is valid, but since execution requires the trick of converting +all operations in terms of rows, then we would be recalculating the B\'ezout coefficients each time.\ + +(* +definition "diagonal_step A i j bezout = (let + (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ (from_nat j) $ (from_nat j)) in + (\ a b. if a = from_nat i \ b = from_nat i then d else + if a = from_nat j \ b = from_nat j + then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b))" +*) + +text\Thus, the definition is parameterized by the necessary elements instead of the operation, + to avoid recalculations.\ + +definition "diagonal_step A i j d v = + (\ a b. if a = from_nat i \ b = from_nat i then d else + if a = from_nat j \ b = from_nat j + then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)" + + +fun diagonal_to_Smith_i :: +"nat list \ 'a::{bezout_ring}^'cols::mod_type^'rows::mod_type \ nat \ ('a bezout) + \ 'a^'cols::mod_type^'rows::mod_type" + where +"diagonal_to_Smith_i [] A i bezout = A" | +"diagonal_to_Smith_i (j#xs) A i bezout = ( + if A $ (from_nat i) $ (from_nat i) dvd A $ (from_nat j) $ (from_nat j) + then diagonal_to_Smith_i xs A i bezout + else let (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j); + A' = diagonal_step A i j d v + in diagonal_to_Smith_i xs A' i bezout + ) + " + +definition "Diagonal_to_Smith_row_i A i bezout + = diagonal_to_Smith_i [i+1.. nat list \ ('a bezout) \ 'a^'cols::mod_type^'rows::mod_type" + where + "diagonal_to_Smith_aux A [] bezout = A" | + "diagonal_to_Smith_aux A (i#xs) bezout + = diagonal_to_Smith_aux (Diagonal_to_Smith_row_i A i bezout) xs bezout" + +text\The minimum arises to include the case of non-square matrices (we do not + demand the input diagonal matrix to be square, just have zeros in non-diagonal entries). + + This iteration does not need to be performed until the last element of the diagonal, + because in the second-to-last step the matrix will be already in Smith normal form.\ + +definition "diagonal_to_Smith A bezout + = diagonal_to_Smith_aux A [0..Code equations to get an executable version\ + +definition diagonal_step_row + where "diagonal_step_row A i j c v a = vec_lambda (%b. if a = from_nat i \ b = from_nat i then c else + if a = from_nat j \ b = from_nat j + then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)" + +lemma diagonal_step_code [code abstract]: + "vec_nth (diagonal_step_row A i j c v a) = (%b. if a = from_nat i \ b = from_nat i then c else + if a = from_nat j \ b = from_nat j + then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)" + unfolding diagonal_step_row_def by auto + +lemma diagonal_step_code_nth [code abstract]: "vec_nth (diagonal_step A i j c v) + = diagonal_step_row A i j c v" + unfolding diagonal_step_def unfolding diagonal_step_row_def[abs_def] + by auto + +text\Code equation to avoid recalculations when computing the Bezout coefficients. \ +lemma euclid_ext2_code[code]: + "euclid_ext2 a b = (let ((p,q),d) = euclid_ext a b in (p,q, - b div d, a div d, d))" + unfolding euclid_ext2_def split_beta Let_def + by auto + +subsection\Examples of execution\ + +value "let A= list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3 + in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)" + +text\Example obtained from: +\url{https://math.stackexchange.com/questions/77063/how-do-i-get-this-matrix-in-smith-normal-form-and-is-smith-normal-form-unique} +\ + +value "let A= list_of_list_to_matrix + [ + [[:-3,1:],0,0,0], + [0,[:1,1:],0,0], + [0,0,[:1,1:],0], + [0,0,0,[:1,1:]]]::rat poly^4^4 + in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)" + + +text\Polynomial matrix\ +value "let A = list_of_list_to_matrix + [ + [[:-3,1:],0,0,0], + [0,[:1,1:],0,0], + [0,0,[:1,1:],0], + [0,0,0,[:1,1:]], + [0,0,0,0]]::rat poly^4^5 + in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)" + + +subsection\Soundness of the algorithm\ + +lemma nrows_diagonal_step[simp]: "nrows (diagonal_step A i j c v) = nrows A" + by (simp add: nrows_def) + +lemma ncols_diagonal_step[simp]: "ncols (diagonal_step A i j c v) = ncols A" + by (simp add: ncols_def) + + +context + fixes bezout::"'a::{bezout_ring} \ 'a \ 'a \ 'a \ 'a \ 'a \ 'a" + assumes ib: "is_bezout_ext bezout" +begin + +lemma split_beta_bezout: "bezout a b = + (fst(bezout a b), + fst (snd (bezout a b)), + fst (snd(snd (bezout a b))), + fst (snd(snd(snd (bezout a b)))), + snd (snd(snd(snd (bezout a b)))))" unfolding split_beta by (auto simp add: split_beta) + +text\The following lemma shows that @{text "diagonal_to_Smith_i"} preserves the previous element. + We use the assumption @{text "to_nat a = to_nat b"} in order to ensure that we are treating with + a diagonal entry. Since the matrix could be rectangular, the types of a and b can be different, + and thus we cannot write either @{text "a = b"} or @{text "A $ a $ b"}.\ + +lemma diagonal_to_Smith_i_preserves_previous_diagonal: + fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type" + assumes i_min: "i < min (nrows A) (ncols A)" + and "to_nat a \ set xs" and "to_nat a = to_nat b" + and "to_nat a \ i" + and elements_xs_range: "\x. x \ set xs \ x from_nat j" + by (metis elements_xs i_notin list.set_intros(1) min_less_iff_conj nrows_def to_nat_from_nat_id) + have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" + using False by (auto simp add: split_beta) + also have "... $ a $ b = ?A' $ a $ b" + by (rule hyp[OF False], insert i_notin i_min a_eq_b a_not_i pquvd elements_xs, auto) + also have "... = A $ a $ b" + unfolding diagonal_step_def + using a_not_j a_not_i + by (smt i_min min.strict_boundedE nrows_def to_nat_from_nat_id vec_lambda_beta) + finally show ?thesis . + qed +qed + +lemma diagonal_step_dvd1[simp]: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" and j i + defines "v==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ v" + and "d==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ d" + shows "diagonal_step A i j d v $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i" + using ib unfolding is_bezout_ext_def diagonal_step_def v_def d_def + by (auto simp add: split_beta) + +lemma diagonal_step_dvd2[simp]: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" and j i + defines "v==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ v" + and "d==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ d" + shows "diagonal_step A i j d v $ from_nat i $ from_nat i dvd A $ from_nat j $ from_nat j" + using ib unfolding is_bezout_ext_def diagonal_step_def v_def d_def + by (auto simp add: split_beta) + +end + +text\Once the step is carried out, the new element ${A'}_{ii}$ will divide the element $A_{ii}$\ + +lemma diagonal_to_Smith_i_dvd_ii: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + shows "diagonal_to_Smith_i xs A i bezout $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i" + using ib +proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct) + case (1 A i bezout) + then show ?case by auto +next + case (2 j xs A i bezout) + let ?Aii = "A $ from_nat i $ from_nat i" + let ?Ajj = "A $ from_nat j $ from_nat j" + let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ p" + let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ q" + let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ u" + let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ v" + let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ d" + let ?A'="diagonal_step A i j ?d ?v" + have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)" + by (simp add: split_beta) + note ib = "2.prems"(1) + show ?case + proof (cases "?Aii dvd ?Ajj") + case True + then show ?thesis + using "2.hyps"(1) "2.prems" by auto + next + case False + note hyp = "2.hyps"(2) + have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" + using False by (auto simp add: split_beta) + also have "... $ from_nat i $ from_nat i dvd ?A' $ from_nat i $ from_nat i" + by (rule hyp[OF False], insert pquvd ib, auto) + also have "... dvd A $ from_nat i $ from_nat i" + unfolding diagonal_step_def using ib unfolding is_bezout_ext_def + by (auto simp add: split_beta) + finally show ?thesis . + qed +qed + +text\Once the step is carried out, the new element ${A'}_{ii}$ + divides the rest of elements of the diagonal. This proof requires commutativity (already + included in the type restriction @{text "bezout_ring"}).\ + +lemma diagonal_to_Smith_i_dvd_jj: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and elements_xs_range: "\x. x \ set xs \ x set xs" + and "to_nat a = to_nat b" + and "to_nat a \ i" + and "distinct xs" +shows "(diagonal_to_Smith_i xs A i bezout) $ (from_nat i) $ (from_nat i) + dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" + using assms +proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct) + case (1 A i) + then show ?case by auto +next + case (2 j xs A i bezout) + let ?Aii = "A $ from_nat i $ from_nat i" + let ?Ajj = "A $ from_nat j $ from_nat j" + let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ p" + let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ q" + let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ u" + let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ v" + let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) \ d" + let ?A'="diagonal_step A i j ?d ?v" + have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)" + by (simp add: split_beta) + note ib = "2.prems"(1) + note to_nat_a_not_i = 2(8) + note i_min = 2(4) + note elements_xs = "2.prems"(3) + note a_eq_b = "2.prems"(5) + note a_in_j_xs = 2(6) + note distinct = 2(9) + show ?case + proof (cases "?Aii dvd ?Ajj") + case True note Aii_dvd_Ajj = True + show ?thesis + proof (cases "to_nat a = j") + case True + have a: "a = (from_nat j::'c)" using True by auto + have b: "b = (from_nat j::'b)" + using True a_eq_b by auto + have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs A i bezout" + using Aii_dvd_Ajj by auto + also have "... $ from_nat j $ from_nat j = A $ from_nat j $ from_nat j" + proof (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib i_min]) + show "to_nat (from_nat j::'c) \ set xs" using True a_in_j_xs distinct by auto + show "to_nat (from_nat j::'c) = to_nat (from_nat j::'b)" + by (metis True a_eq_b from_nat_to_nat_id) + show "to_nat (from_nat j::'c) \ i" + using True to_nat_a_not_i by auto + show "\x. x \ set xs \ x < min (nrows A) (ncols A)" using elements_xs by auto + qed + finally have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat j $ from_nat j + = A $ from_nat j $ from_nat j " . + hence "diagonal_to_Smith_i (j # xs) A i bezout $ a $ b = ?Ajj" unfolding a b . + moreover have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat i $ from_nat i dvd ?Aii" + by (rule diagonal_to_Smith_i_dvd_ii[OF ib]) + ultimately show ?thesis using Aii_dvd_Ajj dvd_trans by auto + next + case False + have a_in_xs: "to_nat a \ set xs" using False using "2.prems"(4) by auto + have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs A i bezout" + using True by auto + also have "... $ (from_nat i) $ (from_nat i) dvd diagonal_to_Smith_i xs A i bezout $ a $ b" + by (rule "2.hyps"(1)[OF True ib i_min _ a_in_xs a_eq_b to_nat_a_not_i]) + (insert elements_xs distinct, auto) + finally show ?thesis . + qed + next + case False note Aii_not_dvd_Ajj = False + show ?thesis + proof (cases "to_nat a \ set xs") + case True note a_in_xs = True + have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" + using False by (auto simp add: split_beta) + also have "... $ from_nat i $ from_nat i dvd diagonal_to_Smith_i xs ?A' i bezout $ a $ b" + by (rule "2.hyps"(2)[OF False _ _ _ _ _ _ _ _ _ a_in_xs a_eq_b to_nat_a_not_i ]) + (insert elements_xs distinct i_min ib pquvd, auto simp add: nrows_def ncols_def) + finally show ?thesis . + next + case False + have to_nat_a_eq_j: "to_nat a = j" + using False a_in_j_xs by auto + have a: "a = (from_nat j::'c)" using to_nat_a_eq_j by auto + have b: "b = (from_nat j::'b)" using to_nat_a_eq_j a_eq_b by auto + have d_eq: "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" + using Aii_not_dvd_Ajj by (simp add: split_beta) + also have "... $ a $ b = ?A' $ a $ b" + by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib _ False a_eq_b to_nat_a_not_i]) + (insert i_min elements_xs ib, auto) + finally have "diagonal_to_Smith_i (j # xs) A i bezout $ a $ b = ?A' $ a $ b" . + moreover have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat i $ from_nat i + dvd ?A' $ from_nat i $ from_nat i" + using d_eq diagonal_to_Smith_i_dvd_ii[OF ib] by simp + moreover have "?A' $ from_nat i $ from_nat i dvd ?A' $ from_nat j $ from_nat j" + unfolding diagonal_step_def using ib unfolding is_bezout_ext_def split_beta + by (auto, meson dvd_mult)+ + ultimately show ?thesis using dvd_trans a b by auto + qed +qed +qed + + +text\The step preserves everything that is not in the diagonal\ + +lemma diagonal_to_Smith_i_preserves_previous: + fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and a_not_b: "to_nat a \ to_nat b" + and elements_xs_range: "\x. x \ set xs \ x b \ from_nat i" + by (metis "2.prems" a_not_b from_nat_not_eq min.strict_boundedE ncols_def nrows_def) + have a2: "a = from_nat j \ b \ from_nat j" + by (metis "2.prems" a_not_b list.set_intros(1) min_less_iff_conj + ncols_def nrows_def to_nat_from_nat_id) + have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" + using False by (simp add: split_beta) + also have "... $ a $ b = ?A' $ a $ b" + by (rule hyp[OF False], insert "2.prems" ib pquvd, auto) + also have "... = A $ a $ b" unfolding diagonal_step_def using a1 a2 by auto + finally show ?thesis . + qed +qed + + +lemma diagonal_step_preserves: + fixes A::"'a::{times}^'b::mod_type^'c::mod_type" + assumes ai: "a \ i" and aj: "a \ j" and a_min: "a < min (nrows A) (ncols A)" + and i_min: "i < min (nrows A) (ncols A)" + and j_min: "j < min (nrows A) (ncols A)" + shows "diagonal_step A i j d v $ from_nat a $ from_nat b = A $ from_nat a $ from_nat b" +proof - + have 1: "(from_nat a::'c) \ from_nat i" + by (metis a_min ai from_nat_eq_imp_eq i_min min.strict_boundedE nrows_def) + have 2: "(from_nat a::'c) \ from_nat j" + by (metis a_min aj from_nat_eq_imp_eq j_min min.strict_boundedE nrows_def) + show ?thesis + using 1 2 unfolding diagonal_step_def by auto +qed + +context GCD_ring +begin + +lemma gcd_greatest: + assumes "is_gcd gcd'" and "c dvd a" and "c dvd b" + shows "c dvd gcd' a b" + using assms is_gcd_def by blast + +end + + +text\This is a key lemma for the soundness of the algorithm.\ + +lemma diagonal_to_Smith_i_dvd: + fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and elements_xs_range: "\x. x \ set xs \ xa b. to_nat a\insert i (set xs) \ to_nat a = to_nat b \ + A $ (from_nat c) $ (from_nat c) dvd A $ a $ b" + and "c \ (set xs)" and c: "c from_nat i" + by (metis "2.prems" False c insert_iff list.set_intros(1) + min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id) + have 2: "(from_nat c::'c) \ from_nat j" + by (metis "2.prems" c insertI1 list.simps(15) min_less_iff_conj nrows_def + to_nat_from_nat_id) + have "?D $ from_nat c $ from_nat c = ?Acc" + unfolding diagonal_step_def using 1 2 by auto + have aux: "?D $ from_nat c $ from_nat c dvd ?D $ a $ b" + if a_in_set: "to_nat a \ insert i (set xs)" and ab: "to_nat a = to_nat b" for a b + proof - + have Acc_dvd_Aii: "?Acc dvd ?Aii" + by (metis "2.prems"(2) "2.prems"(4) insert_iff min.strict_boundedE + ncols_def nrows_def to_nat_from_nat_id) + moreover have Acc_dvd_Ajj: "?Acc dvd ?Ajj" + by (metis "2.prems"(3) "2.prems"(4) insert_iff list.set_intros(1) + min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id) + ultimately have Acc_dvd_gcd: "?Acc dvd ?d" + by (metis (mono_tags, lifting) ib is_gcd_def is_gcd_is_bezout_ext) + show ?thesis + using 1 2 Acc_dvd_Ajj Acc_dvd_Aii Acc_dvd_gcd a_in_set ab dvd_condition + unfolding diagonal_step_def by auto + qed + have "?A' $ from_nat c $ from_nat c = A $ from_nat c $ from_nat c" + unfolding diagonal_step_def using 1 2 by auto + moreover have "?A' $ from_nat c $ from_nat c + dvd diagonal_to_Smith_i xs ?A' i bezout $ from_nat i $ from_nat i" + by (rule hyp[OF False _ _ _ _ _ _ ib]) + (insert nrows_def ncols_def "2.prems" "2.hyps" aux pquvd, auto) + ultimately show ?thesis using False by (auto simp add: split_beta) + qed +qed + + +lemma diagonal_to_Smith_i_dvd2: + fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and elements_xs_range: "\x. x \ set xs \ xa b. to_nat a \ insert i (set xs) \ to_nat a = to_nat b \ + A $ (from_nat c) $ (from_nat c) dvd A $ a $ b" + and c_notin: "c \ (set xs)" + and c: "c < min (nrows A) (ncols A)" + and distinct: "distinct xs" + and ab: "to_nat a = to_nat b" + and a_in: "to_nat a \ insert i (set xs)" + shows "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" +proof (cases "a = from_nat i") + case True + hence b: "b = from_nat i" + by (metis ab from_nat_to_nat_id i_min min_less_iff_conj nrows_def to_nat_from_nat_id) + show ?thesis by (unfold True b, rule diagonal_to_Smith_i_dvd, insert assms, auto) +next + case False + have ai: "to_nat a \ i" using False by auto + hence bi: "to_nat b \ i" by (simp add: ab) + have "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ from_nat i $ from_nat i" + by (rule diagonal_to_Smith_i_dvd, insert assms, auto) + also have "... dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" + by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ai bi, auto) + finally show ?thesis . +qed + + +lemma diagonal_to_Smith_i_dvd2_k: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and elements_xs_range: "\x. x \ set xs \ xmin (nrows A) (ncols A)" + and dvd_condition: "\a b. to_nat a \ insert i (set xs) \ to_nat a = to_nat b \ + A $ (from_nat c) $ (from_nat c) dvd A $ a $ b" + and c_notin: "c \ (set xs)" + and c: "c < min (nrows A) (ncols A)" + and distinct: "distinct xs" + and ab: "to_nat a = to_nat b" + and a_in: "to_nat a \ insert i (set xs)" + shows "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" +proof (cases "a = from_nat i") + case True + hence b: "b = from_nat i" + by (metis ab from_nat_to_nat_id i_min min_less_iff_conj nrows_def to_nat_from_nat_id) + show ?thesis by (unfold True b, rule diagonal_to_Smith_i_dvd, insert assms, auto) +next + case False + have ai: "to_nat a \ i" using False by auto + hence bi: "to_nat b \ i" by (simp add: ab) + have "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ from_nat i $ from_nat i" + by (rule diagonal_to_Smith_i_dvd, insert assms, auto) + also have "... dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" + by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ai bi, auto) + finally show ?thesis . +qed + + + +lemma diagonal_to_Smith_row_i_preserves_previous: + fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and a_not_b: "to_nat a \ to_nat b" + shows "Diagonal_to_Smith_row_i A i bezout $ a $ b = A $ a $ b" + unfolding Diagonal_to_Smith_row_i_def + by (rule diagonal_to_Smith_i_preserves_previous, insert assms, auto) + + +lemma diagonal_to_Smith_row_i_preserves_previous_diagonal: + fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and i_min: "i < min (nrows A) (ncols A)" + and a_notin: "to_nat a \ set [i + 1.. i" + shows "Diagonal_to_Smith_row_i A i bezout $ a $ b = A $ a $ b" + unfolding Diagonal_to_Smith_row_i_def + by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib i_min a_notin ab ai], auto) + +context + fixes bezout::"'a::{bezout_ring} \ 'a \ 'a \ 'a \ 'a \ 'a \ 'a" + assumes ib: "is_bezout_ext bezout" +begin + +lemma diagonal_to_Smith_row_i_dvd_jj: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes "to_nat a \ {i.. {i..i" + and dvd_condition: "\a b. to_nat a \ (set [i.. to_nat a = to_nat b + \ A $ from_nat c $ from_nat c dvd A $ a $ b" + shows "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat c) $ (from_nat c) + dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b" +proof (cases "c = i") + case True + then show ?thesis using assms True diagonal_to_Smith_row_i_dvd_jj + by metis + next + case False + hence ci2: "c (set [i+1.. i" + using ci2 from_nat_mono to_nat_less_card by fastforce + have 3: "to_nat (from_nat c::'c) = to_nat (from_nat c::'b)" + by (metis a_in ab atLeastLessThan_iff ci dual_order.strict_trans2 to_nat_from_nat_id to_nat_less_card) + have "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat c) $ (from_nat c) + = A $(from_nat c) $ (from_nat c)" + unfolding Diagonal_to_Smith_row_i_def + by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib _ 1 3 2], insert assms, auto) + also have "... dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b" + unfolding Diagonal_to_Smith_row_i_def + by (rule diagonal_to_Smith_i_dvd2, insert assms False ci ib, auto) + finally show ?thesis . +qed +end + + +lemma diagonal_to_Smith_aux_append: + "diagonal_to_Smith_aux A (xs @ ys) bezout + = diagonal_to_Smith_aux (diagonal_to_Smith_aux A xs bezout) ys bezout" + by (induct A xs bezout rule: diagonal_to_Smith_aux.induct, auto) + + +lemma diagonal_to_Smith_aux_append2[simp]: + "diagonal_to_Smith_aux A (xs @ [ys]) bezout + = Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A xs bezout) ys bezout" + by (induct A xs bezout rule: diagonal_to_Smith_aux.induct, auto) + + +lemma isDiagonal_eq_upt_k_min: +"isDiagonal A = isDiagonal_upt_k A (min (nrows A) (ncols A))" + unfolding isDiagonal_def isDiagonal_upt_k_def nrows_def ncols_def + by (auto, meson less_trans not_less_iff_gr_or_eq to_nat_less_card) + + +lemma isDiagonal_eq_upt_k_max: +"isDiagonal A = isDiagonal_upt_k A (max (nrows A) (ncols A))" + unfolding isDiagonal_def isDiagonal_upt_k_def nrows_def ncols_def + by (auto simp add: less_max_iff_disj to_nat_less_card) + +lemma isDiagonal: + assumes "isDiagonal A" + and "to_nat a \ to_nat b" shows "A $ a $ b = 0" + using assms unfolding isDiagonal_def by auto + +lemma nrows_diagonal_to_Smith_aux[simp]: + shows "nrows (diagonal_to_Smith_aux A xs bezout) = nrows A" unfolding nrows_def by auto + +lemma ncols_diagonal_to_Smith_aux[simp]: + shows "ncols (diagonal_to_Smith_aux A xs bezout) = ncols A" unfolding ncols_def by auto + +context + fixes bezout::"'a::{bezout_ring} \ 'a \ 'a \ 'a \ 'a \ 'a \ 'a" + assumes ib: "is_bezout_ext bezout" +begin + +lemma isDiagonal_diagonal_to_Smith_aux: + assumes diag_A: "isDiagonal A" and k: "k < min (nrows A) (ncols A)" + shows "isDiagonal (diagonal_to_Smith_aux A [0.. to_nat b" for a b + proof - + have "Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A [0.. 'a \ 'a \ 'a \ 'a \ 'a \ 'a" + assumes ib: "is_bezout_ext bezout" +begin + +text\The variables a and b must be arbitrary in the induction\ +lemma diagonal_to_Smith_aux_dvd: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes ab: "to_nat a = to_nat b" + and c: "c < k" and ca: "c \ to_nat a" and k: "kto_nat a" using ca by auto + show ?thesis unfolding True + by (auto, rule diagonal_to_Smith_row_i_dvd_jj[OF ib _ ab], insert k a_less_ncols, auto) + next + case False note c_not_k = False + let ?Dk="diagonal_to_Smith_aux A [0.. set [k..to_nat a") + case True + show ?thesis + by (auto, rule diagonal_to_Smith_row_i_dvd_jj'[OF ib _ ab]) + (insert True a_less_ncols ck Dkk_Daa_bb, force+) + next + case False + have "diagonal_to_Smith_aux A [0.. k" + using False ca from_nat_mono' to_nat_less_card to_nat_mono' by fastforce + show "to_nat (from_nat c::'c) \ set [k + 1.. to_nat a + 1 < k \ to_nat b + 1 < k" + hence ab: "to_nat a = to_nat b" and ak: "to_nat a + 1 < k" and bk: "to_nat b + 1 < k" by auto + have a_not_k: "to_nat a \ k" using ak by auto + have a1_less_k1: "to_nat a + 1 < k + 1" using ak by linarith + have "?Dk $a $ b = diagonal_to_Smith_aux A [0.. k" using ak + by (metis add_less_same_cancel2 nat_neq_iff not_add_less2 to_nat_0 + to_nat_plus_one_less_card' to_nat_suc) + show "to_nat (a + 1) = to_nat (b + 1)" + by (metis ab ak from_nat_suc from_nat_to_nat_id k less_asym' min_less_iff_conj + ncols_def nrows_def suc_not_zero to_nat_from_nat_id to_nat_plus_one_less_card') + show "to_nat (a + 1) \ set [k + 1.. to_nat b \ (to_nat a < k \ to_nat b < k)" + hence ab: "to_nat a \ to_nat b" and ak_bk: "(to_nat a < k \ to_nat b < k)" by auto + have "?Dk $a $ b = diagonal_to_Smith_aux A [0..k" and "Smith_normal_form_upt_k A k" + shows "Smith_normal_form_upt_k A a" using assms + by (smt Smith_normal_form_upt_k_def isDiagonal_upt_k_def less_le_trans) + +lemma Smith_normal_form_upt_k_imp_Suc_k: + assumes s: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0.. to_nat a + 1 < k \ to_nat b + 1 < k" + hence ab: "to_nat a = to_nat b" and ak: "to_nat a + 1 < k" and bk: "to_nat b + 1 < k" by auto + have a_not_k: "to_nat a \ k" using ak by auto + have a1_less_k1: "to_nat a + 1 < k + 1" using ak by linarith + have "diagonal_to_Smith_aux A [0.. k" using ak + by (metis add_less_same_cancel2 nat_neq_iff not_add_less2 to_nat_0 + to_nat_plus_one_less_card' to_nat_suc) + show "to_nat (a + 1) = to_nat (b + 1)" + by (metis ab ak from_nat_suc from_nat_to_nat_id k less_asym' min_less_iff_conj + ncols_def nrows_def suc_not_zero to_nat_from_nat_id to_nat_plus_one_less_card') + show "to_nat (a + 1) \ set [k + 1.. to_nat b \ (to_nat a < k \ to_nat b < k)" + hence ab: "to_nat a \ to_nat b" and ak_bk: "(to_nat a < k \ to_nat b < k)" by auto + have "diagonal_to_Smith_aux A [0..x. x \ set xs \ xx. x \ set xs \ x 'a \ 'a \ 'a \ 'a \ 'a \ 'a" + assumes ib: "is_bezout_ext bezout" +begin + +text\The algorithm is iterated up to position k (not included). Thus, the matrix +is in Smith normal form up to position k (not included).\ + +lemma Smith_normal_form_upt_k_diagonal_to_Smith_aux: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes "k to_nat (from_nat k::'c)" + by (metis diff_le_self k min_less_iff_conj nrows_def to_nat_from_nat_id) + qed auto + show "isDiagonal (diagonal_to_Smith_aux A [0..This is the soundess lemma.\ + +lemma Smith_normal_form_diagonal_to_Smith: + fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" + assumes ib: "is_bezout_ext bezout" + and d: "isDiagonal A" + shows "Smith_normal_form (diagonal_to_Smith A bezout)" +proof - + let ?k = "min (nrows A) (ncols A) - 2" + let ?Dk = "(diagonal_to_Smith_aux A [0.. to_nat (from_nat ?k::'c)" + by (metis (no_types, lifting) diff_le_self from_nat_not_eq lessI less_le_trans + min.cobounded1 min_eq nrows_def) + qed + qed + have s_eq: "Smith_normal_form (diagonal_to_Smith A bezout) + = Smith_normal_form_upt_k (diagonal_to_Smith A bezout) + (Suc (min (nrows (diagonal_to_Smith A bezout)) (ncols (diagonal_to_Smith A bezout)) - 1))" + unfolding Smith_normal_form_min by (simp add: ncols_def nrows_def) + let ?min1="(min (nrows (diagonal_to_Smith A bezout)) (ncols (diagonal_to_Smith A bezout)) - 1)" + show ?thesis unfolding s_eq + proof (rule Smith_normal_form_upt_k1_intro_diagonal[OF _ d2]) + show "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) ?min1" + using smith_Suc_k min_eq by auto + have "diagonal_to_Smith A bezout $ from_nat ?k $ from_nat ?k + dvd diagonal_to_Smith A bezout $ from_nat (?k + 1) $ from_nat (?k + 1)" + by (smt One_nat_def Suc_eq_plus1 ib Suc_pred diagonal_to_Smith_aux_dvd diagonal_to_Smith_def + le_add1 lessI min_eq min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id zero_less_card_finite) + thus "diagonal_to_Smith A bezout $ from_nat (?min1 - 1) $ from_nat (?min1 - 1) + dvd diagonal_to_Smith A bezout $ from_nat ?min1 $ from_nat ?min1" + using min_eq by auto + qed +qed + +subsection\Implementation and formal proof + of the matrices $P$ and $Q$ which transform the input matrix by means of elementary operations.\ + + +fun diagonal_step_PQ :: "'a::{bezout_ring}^'cols::mod_type^'rows::mod_type \ nat \ nat \ 'a bezout \ +( +('a::{bezout_ring}^'rows::mod_type^'rows::mod_type) \ +('a::{bezout_ring}^'cols::mod_type^'cols::mod_type) +)" + where "diagonal_step_PQ A i k bezout = + (let i_row = from_nat i; k_row = from_nat k; i_col = from_nat i; k_col = from_nat k; + (p, q, u, v, d) = bezout (A $ i_row $ from_nat i) (A $ k_row $ from_nat k); + P = row_add (interchange_rows (row_add (mat 1) k_row i_row p) i_row k_row) k_row i_row (-v); + Q = mult_column (column_add (column_add (mat 1) i_col k_col q) k_col i_col u) k_col (-1) + in (P,Q) + )" + +text\Examples\ + +value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3; + i=0; k=1; + (p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k); + (P,Q) = diagonal_step_PQ A i k euclid_ext2 + in matrix_to_list_of_list (diagonal_step A i k d v)" + +value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3; + i=0; k=1; + (p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k); + (P,Q) = diagonal_step_PQ A i k euclid_ext2 + in matrix_to_list_of_list (P**(A)**Q)" + + +value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3; + i=0; k=1; + (p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k); + (P,Q) = diagonal_step_PQ A i k euclid_ext2 + in matrix_to_list_of_list (P**(A)**Q)" + + +lemmas diagonal_step_PQ_def = diagonal_step_PQ.simps + +lemma from_nat_neq_rows: + fixes A::"'a^'cols::mod_type^'rows::mod_type" + assumes i: "i<(nrows A)" and k: "k<(nrows A)" and ik: "i \ k" + shows "from_nat i \ (from_nat k::'rows)" +proof (rule ccontr, auto) + let ?i="from_nat i::'rows" + let ?k="from_nat k::'rows" + assume "?i = ?k" + hence "to_nat ?i = to_nat ?k" by auto + hence "i = k" + unfolding to_nat_from_nat_id[OF i[unfolded nrows_def]] + unfolding to_nat_from_nat_id[OF k[unfolded nrows_def]] . + thus False using ik by contradiction +qed + + +lemma from_nat_neq_cols: + fixes A::"'a^'cols::mod_type^'rows::mod_type" + assumes i: "i<(ncols A)" and k: "k<(ncols A)" and ik: "i \ k" + shows "from_nat i \ (from_nat k::'cols)" +proof (rule ccontr, auto) + let ?i="from_nat i::'cols" + let ?k="from_nat k::'cols" + assume "?i = ?k" + hence "to_nat ?i = to_nat ?k" by auto + hence "i = k" + unfolding to_nat_from_nat_id[OF i[unfolded ncols_def]] + unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] . + thus False using ik by contradiction +qed + + + +lemma diagonal_step_PQ_invertible_P: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + and i_not_k: "i \ k" + and i: "i (from_nat i::'rows)" + by (rule from_nat_neq_rows, insert i k i_not_k, auto) + have "invertible ?step3" + unfolding row_add_mat_1[of _ _ _ ?step2, symmetric] + proof (rule invertible_mult) + show "invertible (row_add (mat 1) (from_nat k::'rows) (from_nat i) (- v))" + by (rule invertible_row_add[OF i_not_k2]) + show "invertible ?step2" + by (metis i_not_k2 interchange_rows_mat_1 invertible_interchange_rows + invertible_mult invertible_row_add) + qed + thus ?thesis + using PQ p v unfolding diagonal_step_PQ_def Let_def split_beta + by auto +qed + + + +lemma diagonal_step_PQ_invertible_Q: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + and i_not_k: "i \ k" + and i: "i b" + shows "mat q $ a $ b = 0" using ab unfolding mat_def by auto + +text\This is an alternative definition for the matrix P in each step, where entries are + given explicitly instead of being computed as a composition of elementary operations. \ + +lemma diagonal_step_PQ_P_alt: +fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + and i: "i k" +shows " + P = (\ a b. + if a = from_nat i \ b = from_nat i then p else + if a = from_nat i \ b = from_nat k then 1 else + if a = from_nat k \ b = from_nat i then -v * p + 1 else + if a = from_nat k \ b = from_nat k then -v else + if a = b then 1 else 0)" +proof - + have ik1: "from_nat i \ (from_nat k::'rows)" + using from_nat_neq_rows i ik k by auto + have "P $ a $ b = + (if a = from_nat i \ b = from_nat i then p + else if a = from_nat i \ b = from_nat k then 1 + else if a = from_nat k \ b = from_nat i then - v * p + 1 + else if a = from_nat k \ b = from_nat k then - v else if a = b then 1 else 0)" + for a b + using PQ ik1 pquvd + unfolding diagonal_step_PQ_def + unfolding row_add_def interchange_rows_def + by (auto simp add: Let_def split_beta) + (metis (mono_tags, hide_lams) fst_conv snd_conv)+ + thus ?thesis unfolding vec_eq_iff unfolding vec_lambda_beta by auto +qed + + +text\This is an alternative definition for the matrix Q in each step, where entries are + given explicitly instead of being computed as a composition of elementary operations.\ + +lemma diagonal_step_PQ_Q_alt: +fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + and i: "i k" +shows " + Q = (\ a b. + if a = from_nat i \ b = from_nat i then 1 else + if a = from_nat i \ b = from_nat k then -u else + if a = from_nat k \ b = from_nat i then q else + if a = from_nat k \ b = from_nat k then -q*u-1 else + if a = b then 1 else 0)" +proof - + have ik1: "from_nat i \ (from_nat k::'cols)" + using from_nat_neq_cols i ik k by auto + have "Q $ a $ b = + (if a = from_nat i \ b = from_nat i then 1 else + if a = from_nat i \ b = from_nat k then -u else + if a = from_nat k \ b = from_nat i then q else + if a = from_nat k \ b = from_nat k then -q*u-1 else + if a = b then 1 else 0)" for a b + using PQ ik1 pquvd unfolding diagonal_step_PQ_def + unfolding column_add_def mult_column_def + by (auto simp add: Let_def split_beta) + (metis (mono_tags, hide_lams) fst_conv snd_conv)+ + thus ?thesis unfolding vec_eq_iff unfolding vec_lambda_beta by auto +qed + +text\P**A can be rewriten as elementary operations over A.\ + +lemma diagonal_step_PQ_PA: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" +shows "P**A = row_add (interchange_rows + (row_add A (from_nat k) (from_nat i) p) (from_nat i) (from_nat k)) (from_nat k) (from_nat i) (- v)" +proof - + let ?i_row = "from_nat i::'rows" and ?k_row = "from_nat k::'rows" + let ?P1 = "row_add (mat 1) ?k_row ?i_row p" + let ?P2' = "interchange_rows ?P1 ?i_row ?k_row" + let ?P2 = "interchange_rows (mat 1) (from_nat i) (from_nat k)" + let ?P3 = "row_add (mat 1) (from_nat k) (from_nat i) (- v)" + have "P = row_add ?P2' ?k_row ?i_row (- v)" + using PQ b unfolding diagonal_step_PQ_def + by (auto simp add: Let_def split_beta, metis fstI sndI) + also have "... = ?P3 ** ?P2'" + unfolding row_add_mat_1[of _ _ _ ?P2', symmetric] by auto + also have "... = ?P3 ** (?P2 ** ?P1)" + unfolding interchange_rows_mat_1[of _ _ ?P1, symmetric] by auto + also have "... ** A = row_add (interchange_rows + (row_add A (from_nat k) (from_nat i) p) (from_nat i) (from_nat k)) (from_nat k) (from_nat i) (- v)" + by (metis interchange_rows_mat_1 matrix_mul_assoc row_add_mat_1) + finally show ?thesis . +qed + + +lemma diagonal_step_PQ_PAQ': + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + shows "P**A**Q = (mult_column (column_add (column_add (P**A) (from_nat i) (from_nat k) q) + (from_nat k) (from_nat i) u) (from_nat k) (- 1))" +proof - + let ?i_col = "from_nat i::'cols" and ?k_col = "from_nat k::'cols" + let ?Q1="(column_add (mat 1) ?i_col ?k_col q)" + let ?Q2' = "(column_add ?Q1 ?k_col ?i_col u)" + let ?Q2 = "column_add (mat 1) (from_nat k) (from_nat i) u" + let ?Q3 = "mult_column (mat 1) (from_nat k) (- 1)" + have "Q = mult_column ?Q2' ?k_col (-1)" + using PQ b unfolding diagonal_step_PQ_def + by (auto simp add: Let_def split_beta, metis fstI sndI) + also have "... = ?Q2' ** ?Q3" + unfolding mult_column_mat_1[of ?Q2', symmetric] by auto + also have "... = (?Q1**?Q2)**?Q3" + unfolding column_add_mat_1[of ?Q1, symmetric] by auto + also have " (P**A) ** ((?Q1**?Q2)**?Q3) = + (mult_column (column_add (column_add (P**A) ?i_col ?k_col q) ?k_col ?i_col u) ?k_col (- 1))" + by (metis (no_types, lifting) column_add_mat_1 matrix_mul_assoc mult_column_mat_1) + finally show ?thesis . +qed + +corollary diagonal_step_PQ_PAQ: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + shows "P**A**Q = (mult_column (column_add (column_add (row_add (interchange_rows + (row_add A (from_nat k) (from_nat i) p) (from_nat i) + (from_nat k)) (from_nat k) (from_nat i) (- v)) (from_nat i) (from_nat k) q) + (from_nat k) (from_nat i) u) (from_nat k) (- 1))" + using diagonal_step_PQ_PA diagonal_step_PQ_PAQ' assms by metis + +lemma isDiagonal_imp_0: + assumes "isDiagonal A" + and "from_nat a \ from_nat b" + and "a < min (nrows A) (ncols A)" + and "b < min (nrows A) (ncols A)" + shows "A $ from_nat a $ from_nat b = 0" + by (metis assms isDiagonal min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id) + + + +lemma diagonal_step_PQ: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout" + and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)" + and i: "i k" + and ib: "is_bezout_ext bezout" and diag: "isDiagonal A" + shows "diagonal_step A i k d v = P**A**Q" +proof - + let ?i_row = "from_nat i::'rows" + and ?k_row = "from_nat k::'rows" and ?i_col = "from_nat i::'cols" and ?k_col = "from_nat k::'cols" + let ?P1 = "(row_add (mat 1) ?k_row ?i_row p)" + let ?Aii = "A $ ?i_row $ ?i_col" + let ?Akk = "A $ ?k_row $ ?k_col" + have k1: "k (from_nat i::'rows)" + using from_nat_neq_rows i ik k by auto + have a2: "from_nat k \ (from_nat i::'cols)" + using from_nat_neq_cols i ik k by auto + have Aab0: "A $ a $ from_nat b = 0" if ab: "a \ from_nat b" and b_ncols: "b < ncols A" for a b + by (metis ab b_ncols diag from_nat_to_nat_id isDiagonal ncols_def to_nat_from_nat_id) + have Aab0': "A $ from_nat a $ b = 0" if ab: "from_nat a \ b" and a_nrows: "a < nrows A" for a b + by (metis ab a_nrows diag from_nat_to_nat_id isDiagonal nrows_def to_nat_from_nat_id) + show ?thesis + proof (unfold diagonal_step_def vec_eq_iff, auto) + show "d = (P ** A ** Q) $ from_nat i $ from_nat i" + and "d = (P ** A ** Q) $ from_nat i $ from_nat i" + and "d = (P ** A ** Q) $ from_nat i $ from_nat i" + unfolding diagonal_step_PQ_PAQ[OF PQ b] + unfolding mult_column_def column_add_def interchange_rows_def row_add_def + unfolding vec_lambda_beta using a1 a2 + using Aik0 Aki0 d by auto + show "v * A $ from_nat k $ from_nat k = (P ** A ** Q) $ from_nat k $ from_nat k" + and "v * A $ from_nat k $ from_nat k = (P ** A ** Q) $ from_nat k $ from_nat k" + using a1 a2 + unfolding diagonal_step_PQ_PAQ[OF PQ b] mult_column_def column_add_def + unfolding interchange_rows_def row_add_def + unfolding vec_lambda_beta unfolding Aik0 Aki0 by (auto simp add: rw) + fix a::'rows and b::'cols + assume ak: "a \ from_nat k" and ai: "a \ from_nat i" + show "A $ a $ b = (P ** A ** Q) $ a $ b" + using ai ak a1 a2 Aab0 k1 i2 + unfolding diagonal_step_PQ_PAQ[OF PQ b] + unfolding mult_column_def column_add_def interchange_rows_def row_add_def + unfolding vec_lambda_beta by auto + next + fix a::'rows and b::'cols + assume ak: "a \ from_nat k" and ai: "b \ from_nat i" + show "A $ a $ b = (P ** A ** Q) $ a $ b" + using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2 + unfolding diagonal_step_PQ_PAQ[OF PQ b] + unfolding mult_column_def column_add_def interchange_rows_def row_add_def + unfolding vec_lambda_beta by auto + next + fix a::'rows and b::'cols + assume ak: "b \ from_nat k" and ai: "a \ from_nat i" + show "A $ a $ b = (P ** A ** Q) $ a $ b" + using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2 + unfolding diagonal_step_PQ_PAQ[OF PQ b] + unfolding mult_column_def column_add_def interchange_rows_def row_add_def + unfolding vec_lambda_beta apply auto (*TODO: cleanup this sledeghammer proof*) + proof - + assume "d = p * ?Aii+ ?Akk* q" + then have "v * (p * ?Aii) + v * (?Akk* q) = d * v" + by (simp add: ring_class.ring_distribs(1) semiring_normalization_rules(7)) + then have "?Aii- v * (p * ?Aii) - v * (?Akk* q) = 0" + by (simp add: diff_diff_add dv) + then show "?Aii- v * (p * ?Aii) = v * ?Akk* q" + by force + qed + next + fix a::'rows and b::'cols + assume ak: "b \ from_nat k" and ai: "b \ from_nat i" + show "A $ a $ b = (P ** A ** Q) $ a $ b" + using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2 + unfolding diagonal_step_PQ_PAQ[OF PQ b] + unfolding mult_column_def column_add_def interchange_rows_def row_add_def + unfolding vec_lambda_beta by auto + qed +qed + + + +fun diagonal_to_Smith_i_PQ :: +"nat list \ nat \ ('a::{bezout_ring} bezout) + \ (('a^'rows::mod_type^'rows::mod_type)\('a^'cols::mod_type^'rows::mod_type)\ ('a^'cols::mod_type^'cols::mod_type)) + \ (('a^'rows::mod_type^'rows::mod_type)\ ('a^'cols::mod_type^'rows::mod_type) \ ('a^'cols::mod_type^'cols::mod_type))" + where +"diagonal_to_Smith_i_PQ [] i bezout (P,A,Q) = (P,A,Q)" | +"diagonal_to_Smith_i_PQ (j#xs) i bezout (P,A,Q) = ( + if A $ (from_nat i) $ (from_nat i) dvd A $ (from_nat j) $ (from_nat j) + then diagonal_to_Smith_i_PQ xs i bezout (P,A,Q) + else let (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j); + A' = diagonal_step A i j d v; + (P',Q') = diagonal_step_PQ A i j bezout + in diagonal_to_Smith_i_PQ xs i bezout (P'**P,A',Q**Q') \ \Apply the step\ + ) + " + + +text\This is implemented by fun. This way, I can do pattern-matching for $(P,A,Q)$.\ + +fun Diagonal_to_Smith_row_i_PQ + where "Diagonal_to_Smith_row_i_PQ i bezout (P,A,Q) + = diagonal_to_Smith_i_PQ [i + 1..Deleted from the simplified and renamed as it would be a definition.\ + +declare Diagonal_to_Smith_row_i_PQ.simps[simp del] +lemmas Diagonal_to_Smith_row_i_PQ_def = Diagonal_to_Smith_row_i_PQ.simps + +fun diagonal_to_Smith_aux_PQ + where + "diagonal_to_Smith_aux_PQ [] bezout (P,A,Q) = (P,A,Q)" | + "diagonal_to_Smith_aux_PQ (i#xs) bezout (P,A,Q) + = diagonal_to_Smith_aux_PQ xs bezout (Diagonal_to_Smith_row_i_PQ i bezout (P,A,Q))" + + +lemma diagonal_to_Smith_aux_PQ_append: + "diagonal_to_Smith_aux_PQ (xs @ ys) bezout (P,A,Q) + = diagonal_to_Smith_aux_PQ ys bezout (diagonal_to_Smith_aux_PQ xs bezout (P,A,Q))" + by (induct xs bezout "(P,A,Q)" arbitrary: P A Q rule: diagonal_to_Smith_aux_PQ.induct) + (auto, metis prod_cases3) + + +lemma diagonal_to_Smith_aux_PQ_append2[simp]: + "diagonal_to_Smith_aux_PQ (xs @ [ys]) bezout (P,A,Q) + = Diagonal_to_Smith_row_i_PQ ys bezout (diagonal_to_Smith_aux_PQ xs bezout (P,A,Q))" +proof (induct xs bezout "(P,A,Q)" arbitrary: P A Q rule: diagonal_to_Smith_aux_PQ.induct) + case (1 bezout P A Q) + then show ?case + by (metis append.simps(1) diagonal_to_Smith_aux_PQ.simps prod.exhaust) +next + case (2 i xs bezout P A Q) + then show ?case + by (metis (no_types, hide_lams) append_Cons diagonal_to_Smith_aux_PQ.simps(2) prod_cases3) +qed + +(* +definition "diagonal_to_Smith_PQ A bezout + = diagonal_to_Smith_aux_PQ [0..The output is the same as the one in the version where $P$ and $Q$ are not computed.\ + +lemma diagonal_to_Smith_i_PQ_eq: + assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)" + and xs: "\x. x \ set xs \ x < min (nrows A) (ncols A)" + and diag: "isDiagonal B" and i_notin: "i \ set xs" and i: "ix. x \ set xs \ x < min (nrows A) (ncols A)" + and diag: "isDiagonal B" and i_notin: "i \ set xs" and i: "i invertible P' \ invertible Q'" + using assms PAQ ib P Q +proof (induct xs i bezout "(P,B,Q)" arbitrary: P B Q rule:diagonal_to_Smith_i_PQ.induct) + case (1 i bezout) + then show ?case using PAQ by auto +next + case (2 j xs i bezout P B Q) + let ?Bii = "B $ from_nat i $ from_nat i" + let ?Bjj = "B $ from_nat j $ from_nat j" + let ?p="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) \ p" + let ?q="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) \ q" + let ?u="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) \ u" + let ?v="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) \ v" + let ?d="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) \ d" + let ?B'="diagonal_step B i j ?d ?v" + let ?P' = "fst (diagonal_step_PQ B i j bezout)" + let ?Q' = "snd (diagonal_step_PQ B i j bezout)" + have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j)" + by (simp add: split_beta) + show ?case + proof (cases "?Bii dvd ?Bjj") + case True + then show ?thesis using "2.prems" + using "2.hyps"(1) by auto + next + case False + note hyp = "2.hyps"(2) + note P'B'Q' = "2.prems"(1) + note i_min = "2.prems"(5) + note PAQ_B = "2.prems"(6) + note i_notin = "2.prems"(4) + note diagB = "2.prems"(3) + note xs_min = "2.prems"(2) + note ib = "2.prems"(7) + note inv_P = "2.prems"(8) + note inv_Q = "2.prems"(9) + have aux: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P, B, Q) + = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')" + using False by (auto simp add: split_beta) + have i: "i < min (nrows B) (ncols B)" using i_min unfolding nrows_def ncols_def by auto + have j: "j < min (nrows B) (ncols B)" using xs_min unfolding nrows_def ncols_def by auto + show ?thesis + proof (rule hyp[OF False]) + show "(P', B', Q') = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')" + using aux P'B'Q' by auto + have B'_P'B'Q': "?B' = ?P'**B**?Q'" + by (rule diagonal_step_PQ[OF _ _ i j _ ib diagB], insert i_notin pquvd, auto) + show "?P'**P ** A ** (Q**?Q') = ?B'" + unfolding B'_P'B'Q' unfolding PAQ_B[symmetric] + by (simp add: matrix_mul_assoc) + show "isDiagonal ?B'" by (rule isDiagonal_diagonal_step[OF diagB i j]) + show "invertible (?P'** P)" + by (metis inv_P diagonal_step_PQ_invertible_P i i_notin in_set_member + invertible_mult j member_rec(1) prod.exhaust_sel) + show "invertible (Q ** ?Q')" + by (metis diagonal_step_PQ_invertible_Q i i_notin inv_Q + invertible_mult j list.set_intros(1) prod.collapse) + qed (insert pquvd xs_min i_min i_notin ib, auto) + qed +qed + + +corollary diagonal_to_Smith_i_PQ: + assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)" + and xs: "\x. x \ set xs \ x < min (nrows A) (ncols A)" + and diag: "isDiagonal B" and i_notin: "i \ set xs" and i: "i invertible P' \ invertible Q' \ B' = diagonal_to_Smith_i xs B i bezout" + using assms diagonal_to_Smith_i_PQ' diagonal_to_Smith_i_PQ_eq by metis + +lemma Diagonal_to_Smith_row_i_PQ_eq: + assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)" + and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)" + shows "B' = Diagonal_to_Smith_row_i B i bezout" + using assms unfolding Diagonal_to_Smith_row_i_def Diagonal_to_Smith_row_i_PQ_def + using diagonal_to_Smith_i_PQ by (auto simp add: nrows_def ncols_def) + +lemma Diagonal_to_Smith_row_i_PQ': + assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)" + and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)" + shows "B' = P'**A**Q' \ invertible P' \ invertible Q'" + by (rule diagonal_to_Smith_i_PQ'[OF P'B'Q'[unfolded Diagonal_to_Smith_row_i_PQ_def] _ diag _ i], + auto simp add: nrows_def ncols_def) + +lemma Diagonal_to_Smith_row_i_PQ: + assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)" + and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)" + shows "B' = P'**A**Q' \ invertible P' \ invertible Q' \ B' = Diagonal_to_Smith_row_i B i bezout" + using assms Diagonal_to_Smith_row_i_PQ' Diagonal_to_Smith_row_i_PQ_eq by presburger + +end + +context + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" (*This is the input matrix*) + and B::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" (*This is the matrix in each step*) + and P and Q + and bezout::"'a bezout" + assumes PAQ: "P**A**Q = B" + and P: "invertible P" and Q: "invertible Q" + and ib: "is_bezout_ext bezout" +begin + + +lemma diagonal_to_Smith_aux_PQ: + assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_aux_PQ [0.. invertible P' \ invertible Q' \ B' = diagonal_to_Smith_aux B [0.. invertible ?P' \ invertible ?Q' + \ ?B' = diagonal_to_Smith_aux B [0.. invertible P' \ invertible Q'" + proof (rule Diagonal_to_Smith_row_i_PQ') + show "(P', B', Q') = Diagonal_to_Smith_row_i_PQ k bezout (?P',?B',?Q')" using Suc.prems by auto + show "invertible ?P'" using hyp by auto + show "?P' ** A ** ?Q' = ?B'" using hyp by auto + show "invertible ?Q'" using hyp by auto + show "is_bezout_ext bezout" using ib by auto + show "k < min (nrows A) (ncols A)" using k by auto + show diag_B': "isDiagonal ?B'" using diag_B' by auto + qed + ultimately show ?case by auto +qed + +end + +fun diagonal_to_Smith_PQ + where "diagonal_to_Smith_PQ A bezout + = diagonal_to_Smith_aux_PQ [0.. invertible P \ invertible Q \ B = diagonal_to_Smith A bezout" +proof (unfold diagonal_to_Smith_def, rule diagonal_to_Smith_aux_PQ[OF _ _ _ ib _ A]) + let ?P = "mat 1::'a^'rows::mod_type^'rows::mod_type" + let ?Q = "mat 1::'a^'cols::mod_type^'cols::mod_type" + show "(P, B, Q) = diagonal_to_Smith_aux_PQ [0..P Q. + invertible (P::'a^'rows::{mod_type}^'rows::{mod_type}) + \ invertible (Q::'a^'cols::{mod_type}^'cols::{mod_type}) + \ Smith_normal_form (P**A**Q)" +proof - + obtain bezout::"'a bezout" where ib: "is_bezout_ext bezout" + using exists_bezout_ext by blast + obtain P B Q where PBQ: "(P,B,Q) = diagonal_to_Smith_PQ A bezout" + by (metis prod_cases3) + have "B = P**A**Q \ invertible P \ invertible Q \ B = diagonal_to_Smith A bezout" + by (rule diagonal_to_Smith_PQ[OF A ib PBQ]) + moreover have "Smith_normal_form (P**A**Q)" + using Smith_normal_form_diagonal_to_Smith assms calculation ib by fastforce + ultimately show ?thesis by auto +qed + +subsection\The final soundness theorem\ + +lemma diagonal_to_Smith_PQ': + fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}" + assumes A: "isDiagonal A" and ib: "is_bezout_ext bezout" + assumes PBQ: "(P,S,Q) = diagonal_to_Smith_PQ A bezout" + shows "S = P**A**Q \ invertible P \ invertible Q \ Smith_normal_form S" + using A PBQ Smith_normal_form_diagonal_to_Smith diagonal_to_Smith_PQ ib by fastforce + +end diff --git a/thys/Smith_Normal_Form/Diagonal_To_Smith_JNF.thy b/thys/Smith_Normal_Form/Diagonal_To_Smith_JNF.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Diagonal_To_Smith_JNF.thy @@ -0,0 +1,657 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Algorithm to transform a diagonal matrix into its Smith normal form in JNF\ + +theory Diagonal_To_Smith_JNF + imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring +begin + + +text \In this file, we implement an algorithm to transform a diagonal matrix into its Smith +normal form, using the JNF library. + +There are, at least, three possible options: +\begin{enumerate} +\item Implement and prove the soundness of the algorithm from scratch in JNF +\item Implement it in JNF and connect it to the HOL Analysis version by means of transfer rules. +Thus, we could obtain the soundness lemma in JNF. +\item Implement it in JNF, with calls to the HOL Analysis version by means of the functions +@{text " from_hma\<^sub>m"} and @{text "to_hma\<^sub>m"}. That is, transform the matrix to HOL Analysis, apply +the existing algorith in HOL Analysis to get the Smith normal form and then transform the output +to JNF. Then, we could try to get the soundness theorem in JNF by means of +transfer rules and local type definitions. +\end{enumerate} + +The first option requires much effort. As we will see, the third option is not possible. +\ + + +subsection \Attempt with the third option: definitions and conditional transfer rules\ + +context + fixes A::"'a::bezout_ring mat" + assumes "A \ carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)" +begin + +private definition "diagonal_to_Smith_PQ_JNF' bezout = ( + let A' = Mod_Type_Connect.to_hma\<^sub>m A::'a^'nc::mod_type^'nr::mod_type; + (P,S,Q) = (diagonal_to_Smith_PQ A' bezout) + in (Mod_Type_Connect.from_hma\<^sub>m P, Mod_Type_Connect.from_hma\<^sub>m S, Mod_Type_Connect.from_hma\<^sub>m Q))" + +end + +text \This approach will not work. The type is necessary in the definition of the function. +That is, outside the context, the function will be: + +@{text "diagonal_to_Smith_PQ_JNF' TYPE('nc) TYPE('nr) A bezout"} + +And we cannot get rid of such @{text "TYPE('nc)"}. + +That is, we could get a lemma like: + +@{theory_text " +lemma + assumes A \ carrier_mat m n + and (P,S,Q) = diagonal_to_Smith_PQ_JNF' TYPE('nr::mod_type) TYPE('nc::mod_type) A bezout + shows invertible_mat P \ invertible_mat Q \ S = P * A * Q \ Smith_normal_form_mat S +"} + +But we wouldn't be able to get rid of such types. +\ + +subsection \Attempt with the second option: implementation and soundness in JNF\ + + +definition "diagonal_step_JNF A i j d v = + Matrix.mat (dim_row A) (dim_col A) (\ (a,b). if a = i \ b = i then d else + if a = j \ b = j + then v * (A $$ (j,j)) else A $$ (a,b))" + +text \Conditional transfer rules are required, so I prove them within context with assumptions.\ + +context + includes lifting_syntax + fixes i and j::nat + assumes i: "i 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (=) ===> (=) ===> Mod_Type_Connect.HMA_M) + (\A. diagonal_step_JNF A i j) (\B. diagonal_step B i j)" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def + diagonal_step_JNF_def diagonal_step_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def, insert from_nat_eq_imp_eq i j, auto) + +end + +definition diagonal_step_PQ_JNF :: + "'a::{bezout_ring} mat \ nat \ nat \ 'a bezout \ ('a mat \ ('a mat))" + where "diagonal_step_PQ_JNF A i k bezout = + (let m = dim_row A; n = dim_col A; + (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (k,k)); + P = addrow (-v) k i (swaprows i k (addrow p k i (1\<^sub>m m))); + Q = multcol k (-1) (addcol u k i (addcol q i k (1\<^sub>m n))) + in (P,Q) + )" + +context + includes lifting_syntax + fixes i and k::nat + assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))" + and k: "k < min (CARD('nr::mod_type)) (CARD('nc::mod_type))" +begin + +lemma HMA_diagonal_step_PQ[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (=) ===> rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M) + (\A bezout. diagonal_step_PQ_JNF A i k bezout) (\A bezout. diagonal_step_PQ A i k bezout)" +proof (intro rel_funI, goal_cases) + case (1 A A' bezout bezout') + note HMA_M_AA'[transfer_rule] = 1(1) + let ?d_JNF = "(diagonal_step_PQ_JNF A i k bezout)" + let ?d_HA = "(diagonal_step_PQ A' i k bezout)" + have [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nc)" + and [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nr)" + by (metis Mod_Type_Connect.HMA_I_def k min.strict_boundedE to_nat_from_nat_id)+ + have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)" + and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)" + by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+ + have [transfer_rule]: "A $$ (i,i) = A' $h from_nat i $h from_nat i" + proof - + have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)" by (transfer, simp) + also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto + finally show ?thesis . + qed + have [transfer_rule]: "A $$ (k,k) = A' $h from_nat k $h from_nat k" + proof - + have "A $$ (k,k) = index_hma A' (from_nat k) (from_nat k)" by (transfer, simp) + also have "... = A' $h from_nat k $h from_nat k" unfolding index_hma_def by auto + finally show ?thesis . + qed + have dim_row_CARD: "dim_row A = CARD('nr)" + using HMA_M_AA' Mod_Type_Connect.dim_row_transfer_rule by blast + have dim_col_CARD: "dim_col A = CARD('nc)" + using HMA_M_AA' Mod_Type_Connect.dim_col_transfer_rule by blast + let ?p = "fst (bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat k $h from_nat k))" + let ?v = "fst (snd (snd (snd (bezout (A $$ (i, i)) (A $$ (k, k))))))" + have "Mod_Type_Connect.HMA_M (fst ?d_JNF) (fst ?d_HA)" + unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def + unfolding Let_def split_beta dim_row_CARD + by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI) + moreover have "Mod_Type_Connect.HMA_M (snd ?d_JNF) (snd ?d_HA)" + unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def + unfolding Let_def split_beta dim_col_CARD + by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI) + ultimately show ?case unfolding rel_prod_conv using 1 + by (simp add: split_beta) +qed + +end + + +fun diagonal_to_Smith_i_PQ_JNF :: + "nat list \ nat \ ('a::{bezout_ring} bezout) + \ ('a mat \ 'a mat \ 'a mat) \ ('a mat \ 'a mat \ 'a mat)" + where +"diagonal_to_Smith_i_PQ_JNF [] i bezout (P,A,Q) = (P,A,Q)" | +"diagonal_to_Smith_i_PQ_JNF (j#xs) i bezout (P,A,Q) = ( + if A $$ (i,i) dvd A $$ (j,j) + then diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q) + else let (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j)); + A' = diagonal_step_JNF A i j d v; + (P',Q') = diagonal_step_PQ_JNF A i j bezout + in diagonal_to_Smith_i_PQ_JNF xs i bezout (P'*P,A',Q*Q') \ \Apply the step\ + ) + " + +context + includes lifting_syntax + fixes i and xs + assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))" + and xs: "\j\set xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))" +begin + +declare diagonal_step_PQ.simps[simp del] + +lemma HMA_diagonal_to_Smith_i_PQ_aux: "HMA_M3 (P,A,Q) + (P' :: 'a :: bezout_ring ^ 'nr :: mod_type ^ 'nr :: mod_type, + A' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type, + Q' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nc :: mod_type) + \ HMA_M3 (diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q)) + (diagonal_to_Smith_i_PQ xs i bezout (P',A',Q'))" + using i xs +proof (induct xs i bezout "(P',A',Q')" arbitrary: P' A' Q' P A Q rule: diagonal_to_Smith_i_PQ.induct) + case (1 i bezout P' A' Q') + then show ?case by auto +next + case (2 j xs i bezout P' A' Q') + note HMA_M3[transfer_rule] = "2.prems"(1) + note i = 2(4) + note j = 2(5) + note IH1="2.hyps"(1) + note IH2="2.hyps"(2) + have j_min: "j < min CARD('nr) CARD('nc)" using j by auto + have HMA_M_AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" using HMA_M3 by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nc)" + and [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nr)" + by (metis Mod_Type_Connect.HMA_I_def j_min min.strict_boundedE to_nat_from_nat_id)+ + have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)" + and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)" + by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+ + have [transfer_rule]: "A $$ (i, i) = A' $h from_nat i $h from_nat i" + proof - + have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)" by (transfer, simp) + also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto + finally show ?thesis . + qed + have [transfer_rule]: "A $$ (j, j) = A' $h from_nat j $h from_nat j" + proof - + have "A $$ (j,j) = index_hma A' (from_nat j) (from_nat j)" by (transfer, simp) + also have "... = A' $h from_nat j $h from_nat j" unfolding index_hma_def by auto + finally show ?thesis . + qed + show ?case + proof (cases "A $$ (i, i) dvd A $$ (j, j)") + case True + hence "A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" by transfer + then show ?thesis using True IH1 HMA_M3 i j by auto + next + case False + obtain p q u v d where b: "(p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j))" + by (metis prod_cases5) + let ?A'_JNF = "diagonal_step_JNF A i j d v" + obtain P''_JNF Q''_JNF where P''Q''_JNF: "(P''_JNF,Q''_JNF) = diagonal_step_PQ_JNF A i j bezout" + by (metis surjective_pairing) + have not_dvd: "\ A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" using False by transfer + let ?A' = "diagonal_step A' i j d v" + obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ A' i j bezout" + by (metis surjective_pairing) + have b2: "(p, q, u, v, d) = bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat j $h from_nat j)" + using b by (transfer,auto) + let ?D_HA = "diagonal_to_Smith_i_PQ xs i bezout (P''**P',?A',Q'**Q'')" + let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''_JNF*P,?A'_JNF,Q*Q''_JNF)" + have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P, A, Q) = ?D_JNF" + using False b P''Q''_JNF + by (auto, unfold split_beta, metis fst_conv snd_conv) + have rw_2: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P', A', Q') = ?D_HA" + using not_dvd b2 P''Q'' by (auto, unfold split_beta, metis fst_conv snd_conv) + have "HMA_M3 ?D_JNF ?D_HA" + proof (rule IH2[OF not_dvd b2], auto) + have j: "j < min CARD('nr) CARD('nc)" using j by auto + have [transfer_rule]: "rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M + (diagonal_step_PQ_JNF A i j bezout) (diagonal_step_PQ A' i j bezout)" + using HMA_diagonal_step_PQ[OF i j] HMA_M_AA' unfolding rel_fun_def by auto + hence [transfer_rule]: "Mod_Type_Connect.HMA_M P''_JNF P''" + and [transfer_rule]: "Mod_Type_Connect.HMA_M Q''_JNF Q''" + using P''Q'' P''Q''_JNF unfolding rel_prod_conv split_beta + by (metis fst_conv, metis snd_conv) + have [transfer_rule]: "Mod_Type_Connect.HMA_M P P'" using HMA_M3 by auto + show "Mod_Type_Connect.HMA_M (P''_JNF * P) (P'' ** P')" + (* apply (transfer, auto) does not finish the goal*) + by (transfer_prover_start, transfer_step+, auto) + (* note HMA_diagonal_step[OF i j,transfer_rule]*) + (*transfer does not work for the following goal*) + show "Mod_Type_Connect.HMA_M (diagonal_step_JNF A i j d v) (diagonal_step A' i j d v)" + using HMA_diagonal_step[OF i j] HMA_M_AA' unfolding rel_fun_def by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" using HMA_M3 by auto + show "Mod_Type_Connect.HMA_M (Q * Q''_JNF) (Q' ** Q'')" + by (transfer_prover_start, transfer_step+, auto) + qed (insert i j P''Q'', auto) + then show ?thesis using rw_1 rw_2 by auto + qed +qed + +lemma HMA_diagonal_to_Smith_i_PQ[transfer_rule]: + "((=) + ===> (HMA_M3 :: (_ \ (_\('a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type) \ _) \_)) + ===> HMA_M3) (diagonal_to_Smith_i_PQ_JNF xs i) (diagonal_to_Smith_i_PQ xs i)" +proof (intro rel_funI, goal_cases) + case (1 x y bezout bezout') + then show ?case using HMA_diagonal_to_Smith_i_PQ_aux + by (auto, smt HMA_M3.elims(2)) +qed + +end + +fun Diagonal_to_Smith_row_i_PQ_JNF + where "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q) + = diagonal_to_Smith_i_PQ_JNF [i + 1.. (HMA_M3 :: (_ \ (_ \ ('a::bezout_ring^'nc::mod_type^'nr::mod_type) \ _) \ _)) ===> HMA_M3) + (Diagonal_to_Smith_row_i_PQ_JNF i) (Diagonal_to_Smith_row_i_PQ i)" +proof (intro rel_funI, clarify, goal_cases) + case (1 _ bezout P A Q P' A' Q') + note HMA_M3[transfer_rule] = 1 + let ?xs1="[i + 1..j\set ?xs1. j < min CARD('nr) CARD('nc)" using i + by (metis atLeastLessThan_iff ncols_def nrows_def set_upt xs_eq) + have rel: "HMA_M3 (diagonal_to_Smith_i_PQ_JNF ?xs1 i bezout (P,A,Q)) + (diagonal_to_Smith_i_PQ ?xs1 i bezout (P',A',Q'))" + using HMA_diagonal_to_Smith_i_PQ[OF i j_xs] HMA_M3 unfolding rel_fun_def by blast + then show ?case + unfolding Diagonal_to_Smith_row_i_PQ_JNF_def Diagonal_to_Smith_row_i_PQ_def + by (metis Suc_eq_plus1 xs_eq) +qed + +end + +fun diagonal_to_Smith_aux_PQ_JNF + where + "diagonal_to_Smith_aux_PQ_JNF [] bezout (P,A,Q) = (P,A,Q)" | + "diagonal_to_Smith_aux_PQ_JNF (i#xs) bezout (P,A,Q) + = diagonal_to_Smith_aux_PQ_JNF xs bezout (Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q))" + +context + includes lifting_syntax + fixes xs + assumes xs: "\j\set xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))" +begin + +lemma HMA_diagonal_to_Smith_aux_PQ_JNF[transfer_rule]: + "((=) ===> (HMA_M3 :: (_ \ (_ \ ('a::bezout_ring^'nc::mod_type^'nr::mod_type) \ _) \ _)) ===> HMA_M3) + (diagonal_to_Smith_aux_PQ_JNF xs) (diagonal_to_Smith_aux_PQ xs)" +proof (intro rel_funI, clarify, goal_cases) + case (1 _ bezout P A Q P' A' Q') + note HMA_M3[transfer_rule] = 1 + show ?case + using xs HMA_M3 + proof (induct xs arbitrary: P' A' Q' P A Q) + case Nil + then show ?case by auto + next + case (Cons i xs) + note IH = Cons(1) + note HMA_M3 = Cons.prems(2) + have i: "i < min CARD('nr) CARD('nc)" using Cons.prems by auto + let ?D_JNF = "(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P, A, Q))" + let ?D_HA = "(Diagonal_to_Smith_row_i_PQ i bezout (P', A', Q'))" + have rw_1: "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P, A, Q) + = diagonal_to_Smith_aux_PQ_JNF xs bezout ?D_JNF" by auto + have rw_2: "diagonal_to_Smith_aux_PQ (i # xs) bezout (P', A', Q') + = diagonal_to_Smith_aux_PQ xs bezout ?D_HA" by auto + have "HMA_M3 ?D_JNF ?D_HA" + using HMA_Diagonal_to_Smith_row_i_PQ[OF i] HMA_M3 unfolding rel_fun_def by blast + then show ?case + by (auto, smt Cons.hyps HMA_M3.elims(2) list.set_intros(2) local.Cons(2)) + qed +qed + +end + +fun diagonal_to_Smith_PQ_JNF + where "diagonal_to_Smith_PQ_JNF A bezout + = diagonal_to_Smith_aux_PQ_JNF [0..m (dim_row A),A,1\<^sub>m (dim_col A))" + + +declare diagonal_to_Smith_PQ_JNF.simps[simp del] +lemmas diagonal_to_Smith_PQ_JNF_def = diagonal_to_Smith_PQ_JNF.simps + +lemma diagonal_step_PQ_JNF_dim: + assumes A: "A \ carrier_mat m n" + and d: "diagonal_step_PQ_JNF A i j bezout = (P,Q)" + shows "P \ carrier_mat m m \ Q \ carrier_mat n n" + using A d unfolding diagonal_step_PQ_JNF_def split_beta Let_def by auto + +lemma diagonal_step_JNF_dim: + assumes A: "A \ carrier_mat m n" + shows "diagonal_step_JNF A i j d v \ carrier_mat m n" + using A unfolding diagonal_step_JNF_def by auto + +lemma diagonal_to_Smith_i_PQ_JNF_dim: + assumes "P' \ carrier_mat m m \ A' \ carrier_mat m n \ Q' \ carrier_mat n n" + and "diagonal_to_Smith_i_PQ_JNF xs i bezout (P',A',Q') = (P,A,Q)" + shows "P \ carrier_mat m m \ A \ carrier_mat m n \ Q \ carrier_mat n n" + using assms + proof (induct xs i bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_i_PQ_JNF.induct) + case (1 i bezout P A Q) + then show ?case by auto + next + case (2 j xs i bezout P' A' Q') + show ?case + proof (cases "A' $$ (i, i) dvd A' $$ (j, j)") + case True + then show ?thesis using 2 by auto + next + case False + obtain p q u v d where b: "(p, q, u, v, d) = bezout (A' $$ (i,i)) (A' $$ (j,j))" + by (metis prod_cases5) + let ?A' = "diagonal_step_JNF A' i j d v" + obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ_JNF A' i j bezout" + by (metis surjective_pairing) + let ?A' = "diagonal_step_JNF A' i j d v" + let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''*P',?A',Q'*Q'')" + have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P', A', Q') = ?D_JNF" + using False b P''Q'' + by (auto, unfold split_beta, metis fst_conv snd_conv) + show ?thesis + proof (rule "2.hyps"(2)[OF False b]) + show "?D_JNF = (P,A,Q)" using rw_1 2 by auto + have "P'' \ carrier_mat m m" and "Q'' \ carrier_mat n n" + using diagonal_step_PQ_JNF_dim[OF _ P''Q''[symmetric]] "2.prems" by auto + thus "P'' * P' \ carrier_mat m m \ ?A' \ carrier_mat m n \ Q' * Q'' \ carrier_mat n n" + using diagonal_step_JNF_dim 2 by (metis mult_carrier_mat) + qed (insert P''Q'', auto) + qed +qed + +lemma Diagonal_to_Smith_row_i_PQ_JNF_dim: + assumes "P' \ carrier_mat m m \ A' \ carrier_mat m n \ Q' \ carrier_mat n n" + and "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P',A',Q') = (P,A,Q)" + shows "P \ carrier_mat m m \ A \ carrier_mat m n \ Q \ carrier_mat n n" + by (rule diagonal_to_Smith_i_PQ_JNF_dim, insert assms, + auto simp add: Diagonal_to_Smith_row_i_PQ_JNF_def) + +lemma diagonal_to_Smith_aux_PQ_JNF_dim: + assumes "P' \ carrier_mat m m \ A' \ carrier_mat m n \ Q' \ carrier_mat n n" + and "diagonal_to_Smith_aux_PQ_JNF xs bezout (P',A',Q') = (P,A,Q)" + shows "P \ carrier_mat m m \ A \ carrier_mat m n \ Q \ carrier_mat n n" + using assms + proof (induct xs bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_aux_PQ_JNF.induct) + case (1 bezout P A Q) + then show ?case by simp + next + case (2 i xs bezout P' A' Q') + let ?D="(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q'))" + have "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P', A', Q') = + diagonal_to_Smith_aux_PQ_JNF xs bezout ?D" by auto + hence *: "... = (P,A,Q)" using 2 by auto + let ?P="fst ?D" + let ?S="fst (snd ?D)" + let ?Q="snd (snd ?D)" + show ?case + proof (rule "2.hyps") + show "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q') = (?P,?S,?Q)" by auto + show "diagonal_to_Smith_aux_PQ_JNF xs bezout (?P, ?S, ?Q) = (P, A, Q)" using * by simp + show "?P \ carrier_mat m m \ ?S \ carrier_mat m n \ ?Q \ carrier_mat n n" + by (rule Diagonal_to_Smith_row_i_PQ_JNF_dim, insert 2, auto) + qed +qed + +lemma diagonal_to_Smith_PQ_JNF_dim: + assumes "A \ carrier_mat m n" + and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P,S,Q)" + shows "P \ carrier_mat m m \ S \ carrier_mat m n \ Q \ carrier_mat n n" + by (rule diagonal_to_Smith_aux_PQ_JNF_dim, insert assms, + auto simp add: diagonal_to_Smith_PQ_JNF_def) + +context + includes lifting_syntax +begin + +lemma HMA_diagonal_to_Smith_PQ_JNF[transfer_rule]: + "((Mod_Type_Connect.HMA_M) ===> (=) ===> HMA_M3) (diagonal_to_Smith_PQ_JNF) (diagonal_to_Smith_PQ)" +proof (intro rel_funI, clarify, goal_cases) + case (1 A A' _ bezout) + let ?xs1 = "[0..j\set ?xs1. j < min CARD('c) CARD('b)" + using dc dr less_imp_diff_less by auto + let ?D_JNF = "diagonal_to_Smith_aux_PQ_JNF ?xs1 bezout ?PAQ" + let ?D_HA = "diagonal_to_Smith_aux_PQ ?xs1 bezout (mat 1, A', mat 1)" + have mat_rel_init: "HMA_M3 ?PAQ (mat 1, A', mat 1)" + proof - + have "Mod_Type_Connect.HMA_M (1\<^sub>m (dim_row A)) (mat 1::'a^'c::mod_type^'c::mod_type)" + unfolding dr by (transfer_prover_start,transfer_step, auto) + moreover have "Mod_Type_Connect.HMA_M (1\<^sub>m (dim_col A)) (mat 1::'a^'b::mod_type^'b::mod_type)" + unfolding dc by (transfer_prover_start,transfer_step, auto) + ultimately show ?thesis using 1 by auto + qed + have "HMA_M3 ?D_JNF ?D_HA" + using HMA_diagonal_to_Smith_aux_PQ_JNF[OF j_xs] mat_rel_init unfolding rel_fun_def by blast + then show ?case using xs_eq unfolding diagonal_to_Smith_PQ_JNF_def diagonal_to_Smith_PQ_def + by auto +qed + +end + +subsection \Applying local type definitions\ + +text \Now we get the soundness lemma in JNF, via the one in HOL Analysis. I need transfer rules +and local type definitions.\ + +context + includes lifting_syntax +begin + + +private lemma diagonal_to_Smith_PQ_JNF_with_types: + assumes A: "A \ carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)" + and S: "S \ carrier_mat CARD('nr) CARD('nc)" + and P: "P \ carrier_mat CARD('nr) CARD('nr)" + and Q: "Q \ carrier_mat CARD('nc) CARD('nc)" + and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)" + and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout" +shows "S = P * A * Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S" +proof - + let ?P = "Mod_Type_Connect.to_hma\<^sub>m P::'a^'nr::mod_type^'nr::mod_type" + let ?A = "Mod_Type_Connect.to_hma\<^sub>m A::'a^'nc::mod_type^'nr::mod_type" + let ?Q = "Mod_Type_Connect.to_hma\<^sub>m Q::'a^'nc::mod_type^'nc::mod_type" + let ?S = "Mod_Type_Connect.to_hma\<^sub>m S::'a^'nc::mod_type^'nr::mod_type" + have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A" + by (simp add: Mod_Type_Connect.HMA_M_def A) + moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M P ?P" + by (simp add: Mod_Type_Connect.HMA_M_def P) + moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M Q ?Q" + by (simp add: Mod_Type_Connect.HMA_M_def Q) + moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M S ?S" + by (simp add: Mod_Type_Connect.HMA_M_def S) + ultimately have [transfer_rule]: "HMA_M3 (P,S,Q) (?P,?S,?Q)" by simp + have [transfer_rule]: "bezout = bezout" .. + have PSQ2: "(?P,?S,?Q) = diagonal_to_Smith_PQ ?A bezout" by (transfer, insert PSQ, auto) + have "?S = ?P**?A**?Q \ invertible ?P \ invertible ?Q \ Smith_normal_form ?S" + by (rule diagonal_to_Smith_PQ'[OF _ ib PSQ2], transfer, auto simp add: d) + with this[untransferred] show ?thesis by auto +qed + + +private lemma diagonal_to_Smith_PQ_JNF_mod_ring_with_types: + assumes A: "A \ carrier_mat CARD('nr::nontriv mod_ring) CARD('nc::nontriv mod_ring)" + and S: "S \ carrier_mat CARD('nr mod_ring) CARD('nc mod_ring)" + and P: "P \ carrier_mat CARD('nr mod_ring) CARD('nr mod_ring)" + and Q: "Q \ carrier_mat CARD('nc mod_ring) CARD('nc mod_ring)" + and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)" + and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout" +shows "S = P * A * Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S" + by (rule diagonal_to_Smith_PQ_JNF_with_types[OF assms]) + + +(*I don't know how to internalize the sort constraint of 'nr and 'nc at once, +so I do it in two steps.*) +thm diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring, + internalize_sort "'nr::nontriv"] + +private lemma diagonal_to_Smith_PQ_JNF_internalized_first: + "class.nontriv TYPE('a::type) \ + A \ carrier_mat CARD('a) CARD('nc::nontriv) \ + S \ carrier_mat CARD('a) CARD('nc) \ + P \ carrier_mat CARD('a) CARD('a) \ + Q \ carrier_mat CARD('nc) CARD('nc) \ + diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) \ + isDiagonal_mat A \ is_bezout_ext bezout \ + S = P * A * Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S" + using diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring, + internalize_sort "'nr::nontriv"] by blast + + +private lemma diagonal_to_Smith_PQ_JNF_internalized: + "class.nontriv TYPE('c::type) \ + class.nontriv TYPE('a::type) \ + A \ carrier_mat CARD('a) CARD('c) \ + S \ carrier_mat CARD('a) CARD('c) \ + P \ carrier_mat CARD('a) CARD('a) \ + Q \ carrier_mat CARD('c) CARD('c) \ + diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) \ + isDiagonal_mat A \ is_bezout_ext bezout \ +S = P * A * Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S" + using diagonal_to_Smith_PQ_JNF_internalized_first[internalize_sort "'nc::nontriv"] by blast + + +context + fixes m::nat and n::nat + assumes local_typedef1: "\(Rep :: ('b \ int)) Abs. type_definition Rep Abs {0..(Rep :: ('c \ int)) Abs. type_definition Rep Abs {0..1" + and n: "n>1" +begin + +lemma type_to_set1: + shows "class.nontriv TYPE('b)" (is ?a) and "m=CARD('b)" (is ?b) +proof - + from local_typedef1 obtain Rep::"('b \ int)" and Abs + where t: "type_definition Rep Abs {0.. int)" and Abs + where t: "type_definition Rep Abs {0.. carrier_mat m n" + assumes PSQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout" + shows "S = P*A*Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S + \ P \ carrier_mat m m \ S \ carrier_mat m n \ Q \ carrier_mat n n" +proof - + have dim_matrices: "P \ carrier_mat m m \ S \ carrier_mat m n \ Q \ carrier_mat n n" + by (rule diagonal_to_Smith_PQ_JNF_dim[OF A_dim PSQ[symmetric]]) + show ?thesis + using diagonal_to_Smith_PQ_JNF_internalized[where ?'c='c, where ?'a='b, + OF type_to_set2(1) type_to_set(1), of m A S P Q] + unfolding type_to_set1(2)[symmetric] type_to_set2(2)[symmetric] + using assms m dim_matrices local_typedef1 by auto +qed +end +end + +(*Canceling the first local type definitions (I was not able to cancel both in one step)*) +context +begin +private lemma diagonal_to_Smith_PQ_JNF_canceled_first: + "\Rep Abs. type_definition Rep Abs {0.. {0.. {} \ + 1 < m \ 1 < n \ isDiagonal_mat A \ is_bezout_ext bezout \ + A \ carrier_mat m n \ (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout \ + S = P * A * Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S + \ P \ carrier_mat m m \ S \ carrier_mat m n \ Q \ carrier_mat n n" + using diagonal_to_Smith_PQ_JNF_local_typedef[cancel_type_definition] by blast + +(*Canceling the second*) +private lemma diagonal_to_Smith_PQ_JNF_canceled_both: + "{0.. {} \ {0.. {} \ 1 < m \ 1 < n \ + isDiagonal_mat A \ is_bezout_ext bezout \ A \ carrier_mat m n \ + (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout \ S = P * A * Q \ + invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S + \ P \ carrier_mat m m \ S \ carrier_mat m n \ Q \ carrier_mat n n" + using diagonal_to_Smith_PQ_JNF_canceled_first[cancel_type_definition] by blast + +subsection \The final result\ + +lemma diagonal_to_Smith_PQ_JNF: + assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout" + and "A \ carrier_mat m n" + and PBQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout" +(*The following two assumptions appear since mod_type requires 11" and m: "m>1" + shows "S = P*A*Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S + \ P \ carrier_mat m m \ S \ carrier_mat m n \ Q \ carrier_mat n n" + using diagonal_to_Smith_PQ_JNF_canceled_both[OF _ _ m n] using assms by force +end +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/Diagonalize.thy b/thys/Smith_Normal_Form/Diagonalize.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Diagonalize.thy @@ -0,0 +1,89 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Diagonalizing matrices in JNF and HOL Analysis\ + +theory Diagonalize + imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring +begin + + +text \This section presents a @{text "locale"} that assumes a sound operation to make a matrix +diagonal. Then, the result is transferred to HOL Analysis.\ + +subsection \Diagonalizing matrices in JNF\ + +text \We assume a @{text "diagonalize_JNF"} operation in JNF, which is applied to matrices over +a B\'ezout ring. However, probably a more restrictive type class is required.\ + +locale diagonalize = + fixes diagonalize_JNF :: "'a::bezout_ring mat \ 'a bezout \ ('a mat \ 'a mat \ 'a mat)" + assumes soundness_diagonalize_JNF: + "\A bezout. A \ carrier_mat m n \ is_bezout_ext bezout \ + (case diagonalize_JNF A bezout of (P,S,Q) \ + P \ carrier_mat m m \ Q \ carrier_mat n n \ S \ carrier_mat m n + \ invertible_mat P \ invertible_mat Q \ isDiagonal_mat S \ S = P*A*Q)" +begin + +lemma soundness_diagonalize_JNF': + fixes A::"'a mat" + assumes "is_bezout_ext bezout" and "A \ carrier_mat m n" + and "diagonalize_JNF A bezout = (P,S,Q)" + shows "P \ carrier_mat m m \ Q \ carrier_mat n n \ S \ carrier_mat m n + \ invertible_mat P \ invertible_mat Q \ isDiagonal_mat S \ S = P*A*Q" + using soundness_diagonalize_JNF assms unfolding case_prod_beta by (metis fst_conv snd_conv) + + +subsection \Implementation and soundness result moved to HOL Analysis.\ + +definition diagonalize :: "'a::bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type + \ 'a bezout \ + (('a ^ 'nr :: mod_type ^ 'nr :: mod_type) + \ ('a ^ 'nc :: mod_type ^ 'nr :: mod_type) + \ ('a ^ 'nc :: mod_type ^ 'nc :: mod_type))" + where "diagonalize A bezout = ( + let (P,S,Q) = diagonalize_JNF (Mod_Type_Connect.from_hma\<^sub>m A) bezout + in (Mod_Type_Connect.to_hma\<^sub>m P,Mod_Type_Connect.to_hma\<^sub>m S,Mod_Type_Connect.to_hma\<^sub>m Q) + )" + +lemma soundness_diagonalize: + assumes b: "is_bezout_ext bezout" + and d: "diagonalize A bezout = (P,S,Q)" +shows "invertible P \ invertible Q \ isDiagonal S \ S = P**A**Q" +proof - + define A' where "A' = Mod_Type_Connect.from_hma\<^sub>m A" + obtain P' S' Q' where d_JNF: "(P',S',Q') = diagonalize_JNF A' bezout" + by (metis prod_cases3) + define m and n where "m = dim_row A'" and "n = dim_col A'" + hence A': "A' \ carrier_mat m n" by auto + have res_JNF: "P' \ carrier_mat m m \ Q' \ carrier_mat n n \ S' \ carrier_mat m n + \ invertible_mat P' \ invertible_mat Q' \ isDiagonal_mat S' \ S' = P'*A'*Q'" + by (rule soundness_diagonalize_JNF'[OF b A' d_JNF[symmetric]]) + have "Mod_Type_Connect.to_hma\<^sub>m P' = P" using d unfolding diagonalize_def Let_def + by (metis A'_def d_JNF fst_conv old.prod.case) + hence "P' = Mod_Type_Connect.from_hma\<^sub>m P" using A'_def m_def res_JNF by auto + hence [transfer_rule]: "Mod_Type_Connect.HMA_M P' P" + unfolding Mod_Type_Connect.HMA_M_def by auto + have "Mod_Type_Connect.to_hma\<^sub>m Q' = Q" using d unfolding diagonalize_def Let_def + by (metis A'_def d_JNF snd_conv old.prod.case) + hence "Q' = Mod_Type_Connect.from_hma\<^sub>m Q" using A'_def n_def res_JNF by auto + hence [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q" + unfolding Mod_Type_Connect.HMA_M_def by auto + have "Mod_Type_Connect.to_hma\<^sub>m S' = S" using d unfolding diagonalize_def Let_def + by (metis A'_def d_JNF snd_conv old.prod.case) + hence "S' = Mod_Type_Connect.from_hma\<^sub>m S" using A'_def m_def n_def res_JNF by auto + hence [transfer_rule]: "Mod_Type_Connect.HMA_M S' S" + unfolding Mod_Type_Connect.HMA_M_def by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_M A' A" + using A'_def unfolding Mod_Type_Connect.HMA_M_def by auto + have "invertible P" using res_JNF by (transfer, simp) + moreover have "invertible Q" using res_JNF by (transfer, simp) + moreover have "isDiagonal S" using res_JNF by (transfer, simp) + moreover have "S = P**A**Q" using res_JNF by (transfer, simp) + ultimately show ?thesis by simp +qed +end + +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/Elementary_Divisor_Rings.thy b/thys/Smith_Normal_Form/Elementary_Divisor_Rings.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Elementary_Divisor_Rings.thy @@ -0,0 +1,1396 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Elementary divisor rings\ + +theory Elementary_Divisor_Rings + imports + SNF_Algorithm + Rings2_Extended +begin + +text \This theory contains the definition of elementary divisor rings and Hermite rings, as +well as the corresponding relation between both concepts. +It also includes a complete characterization +for elementary divisor rings, by means of an \emph{if and only if}-statement. + +The results presented here follows the article ``Some remarks about elementary divisor rings'' +by Leonard Gillman and Melvin Henriksen.\ + +subsection \Previous definitions and basic properties of Hermite ring\ + +definition "admits_triangular_reduction A = + (\U::'a::comm_ring_1 mat. U \ carrier_mat (dim_col A) (dim_col A) + \ invertible_mat U \ lower_triangular (A*U))" + +class Hermite_ring = + assumes "\(A::'a::comm_ring_1 mat). admits_triangular_reduction A" + +lemma admits_triangular_reduction_intro: + assumes "invertible_mat (U::'a::comm_ring_1 mat)" + and "U \ carrier_mat (dim_col A) (dim_col A)" + and "lower_triangular (A*U)" + shows "admits_triangular_reduction A" + using assms unfolding admits_triangular_reduction_def by auto + +lemma OFCLASS_Hermite_ring_def: + "OFCLASS('a::comm_ring_1, Hermite_ring_class) + \ (\(A::'a::comm_ring_1 mat). admits_triangular_reduction A)" +proof + fix A::"'a mat" + assume H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)" + have "\A. admits_triangular_reduction (A::'a mat)" + using conjunctionD2[OF H[unfolded Hermite_ring_class_def class.Hermite_ring_def]] by auto + thus "admits_triangular_reduction A" by auto +next + assume i: "(\A::'a mat. admits_triangular_reduction A)" + show "OFCLASS('a, Hermite_ring_class)" + proof + show "\A::'a mat. admits_triangular_reduction A" using i by auto + qed +qed + + +definition admits_diagonal_reduction::"'a::comm_ring_1 mat \ bool" + where "admits_diagonal_reduction A = (\P Q. P \ carrier_mat (dim_row A) (dim_row A) \ + Q \ carrier_mat (dim_col A) (dim_col A) + \ invertible_mat P \ invertible_mat Q + \ Smith_normal_form_mat (P * A * Q))" + +lemma admits_diagonal_reduction_intro: + assumes "P \ carrier_mat (dim_row A) (dim_row A)" + and "Q \ carrier_mat (dim_col A) (dim_col A)" + and "invertible_mat P" and "invertible_mat Q " + and "Smith_normal_form_mat (P * A * Q)" + shows "admits_diagonal_reduction A" using assms unfolding admits_diagonal_reduction_def by fast + +(*Lemmas for equivalence between admits_diagonal_reduction and is_SNF + via the existence of an algorithm*) + +lemma admits_diagonal_reduction_imp_exists_algorithm_is_SNF: + assumes "A \ carrier_mat m n" + and "admits_diagonal_reduction A" +shows "\algorithm. is_SNF A (algorithm A)" + using assms unfolding is_SNF_def admits_diagonal_reduction_def + by auto + +lemma exists_algorithm_is_SNF_imp_admits_diagonal_reduction: + assumes "A \ carrier_mat m n" + and "\algorithm. is_SNF A (algorithm A)" + shows "admits_diagonal_reduction A" + using assms unfolding is_SNF_def admits_diagonal_reduction_def + by auto + +lemma admits_diagonal_reduction_eq_exists_algorithm_is_SNF: + assumes A: "A \ carrier_mat m n" + shows "admits_diagonal_reduction A = (\algorithm. is_SNF A (algorithm A))" + using admits_diagonal_reduction_imp_exists_algorithm_is_SNF[OF A] + using exists_algorithm_is_SNF_imp_admits_diagonal_reduction[OF A] + by auto + + +lemma admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all: + assumes "(\(A::'a::comm_ring_1 mat) \ carrier_mat m n. admits_diagonal_reduction A)" + shows" (\algorithm. \(A::'a mat) \ carrier_mat m n. is_SNF A (algorithm A))" +proof - + let ?algorithm = "\A. SOME (P, S, Q). is_SNF A (P,S,Q)" + show ?thesis + by (rule exI[of _ ?algorithm]) (metis (no_types, lifting) + admits_diagonal_reduction_imp_exists_algorithm_is_SNF assms case_prod_beta prod.collapse someI) +qed + +lemma exists_algorithm_is_SNF_imp_admits_diagonal_reduction_all: + assumes "(\algorithm. \(A::'a mat) \ carrier_mat m n. is_SNF A (algorithm A))" + shows "(\(A::'a::comm_ring_1 mat) \ carrier_mat m n. admits_diagonal_reduction A)" + using assms exists_algorithm_is_SNF_imp_admits_diagonal_reduction by blast + + +lemma admits_diagonal_reduction_eq_exists_algorithm_is_SNF_all: + shows "(\(A::'a::comm_ring_1 mat) \ carrier_mat m n. admits_diagonal_reduction A) + = (\algorithm. \(A::'a mat) \ carrier_mat m n. is_SNF A (algorithm A))" + using exists_algorithm_is_SNF_imp_admits_diagonal_reduction_all + using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all by auto + + +subsection \The class that represents elementary divisor rings\ + +class elementary_divisor_ring = + assumes "\(A::'a::comm_ring_1 mat). admits_diagonal_reduction A" + + +lemma dim_row_mat_diag[simp]: "dim_row (mat_diag n f) = n" and + dim_col_mat_diag[simp]: "dim_col (mat_diag n f) = n" + using mat_diag_dim unfolding carrier_mat_def by auto+ + + +subsection \Hermite ring implies B\'ezout ring\ + +(*HERMITE \ BEZOUT*) + +text \To prove this fact, we make use of the alternative definition for B\'ezout rings: +each finitely generated ideal is principal\ + +lemma Hermite_ring_imp_Bezout_ring: + assumes H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)" + shows " OFCLASS('a::comm_ring_1, bezout_ring_class)" +proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule+) + fix I::"'a set" assume fin: "finitely_generated_ideal I" + (*We take the list, put it in a 1xn matrix and then multiply it by a matrix Q that I will obtain*) + obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S" + using fin unfolding finitely_generated_ideal_def by auto + obtain xs where set_xs: "set xs = S" and d: "distinct xs" + using finite_distinct_list[OF fin_S] by blast + hence length_eq_card: "length xs = card S" using distinct_card by force + define n where "n = card S" + define A where "A = mat_of_rows n [vec_of_list xs]" + have A[simp]: "A \ carrier_mat 1 n" unfolding A_def using mat_of_rows_carrier by auto + have "\(A::'a::comm_ring_1 mat). admits_triangular_reduction A" + using H unfolding OFCLASS_Hermite_ring_def by auto + from this obtain Q where inv_Q: "invertible_mat Q" and t_AQ: "lower_triangular (A*Q)" + and Q[simp]: "Q \ carrier_mat n n" + unfolding admits_triangular_reduction_def using A by auto + have AQ[simp]: "A * Q \ carrier_mat 1 n" using A Q by auto + show "principal_ideal I" + proof (cases "xs=[]") + case True + then show ?thesis + by (metis empty_set ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def set_xs) + next + case False + have a: "0 < dim_row A" using A by auto + have "0 < length xs" using False by auto + hence b: "0 < dim_col A" using A n_def length_eq_card by auto + have q0: "0 < dim_col Q" by (metis A Q b carrier_matD(2)) + have n0: "00 < length xs\ length_eq_card n_def by linarith + define d where "d = (A*Q) $$ (0,0)" + let ?h = "(\x. THE i. xs ! i = x \ i set xs" and y: "y \ set xs" + and xy: "(THE i. xs ! i = x \ i < n) = (THE i. xs ! i = y \ i < n)" for x y + proof - + let ?i = "(THE i. xs ! i = x \ i < n)" + let ?j = "(THE i. xs ! i = y \ i < n)" + obtain i where xs_i: "xs ! i = x \ i < n" using x + by (metis in_set_conv_nth length_eq_card n_def) + from this have 1: "xs ! ?i = x \ ?i < n" + by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce) + obtain j where xs_j: "xs ! j = y \ j < n" using y + by (metis in_set_conv_nth length_eq_card n_def) + from this have 2: "xs ! ?j = y \ ?j < n" + by (rule theI, insert d xs_j length_eq_card n_def nth_eq_iff_index_eq, fastforce) + show ?thesis using 1 2 d xy by argo + qed + thus ?thesis unfolding inj_on_def by auto + qed + show "(\x. THE i. xs ! i = x \ i < n) ` set xs = {0.. set xs" + let ?i = "(THE i. xs ! i = xa \ i < n)" + obtain i where xs_i: "xs ! i = xa \ i < n" using xa + by (metis in_set_conv_nth length_eq_card n_def) + from this have 1: "xs ! ?i = xa \ ?i < n" + by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce) + thus "(THE i. xs ! i = xa \ i < n) < n" by simp + next + fix x assume x: "xxa\set xs. x = (THE i. xs ! i = xa \ i < n)" + by (rule bexI[of _ "xs ! x"], rule the_equality[symmetric], insert x d) + (auto simp add: length_eq_card n_def nth_eq_iff_index_eq)+ + thus "x \ (\x. THE i. xs ! i = x \ i < n) ` set xs" unfolding image_def by auto + qed + qed + have i: "ideal_generated {d} = ideal_generated S" + proof - + have ideal_S_explicit: "ideal_generated S = {y. \f. (\i\S. f i * i) = y}" + unfolding ideal_explicit2[OF fin_S] by simp + have "ideal_generated {d} \ ideal_generated S" + proof (rule ideal_generated_subset2, auto simp add: ideal_S_explicit) + have n: "dim_vec (col Q 0) = n" using Q n_def by auto + have aux: "Matrix.row A 0 $v i = xs ! i" if i: "i col Q 0" by (rule index_mult_mat(1)[OF a q0]) + also have "... = (\i = 0..i = 0..i = 0..x \ set xs. ?g (?h x))" + by (rule sum.reindex_bij_betw[symmetric, OF bij]) + also have "... = (\x \ set xs. ?f x * x)" + proof (rule sum.cong, auto simp add: Let_def) + fix x assume x: "x \ set xs" + let ?i = "(THE i. xs ! i = x \ i < n)" + obtain i where xs_i: "xs ! i = x \ i < n" + by (metis in_set_conv_nth x length_eq_card n_def) + from this have "xs ! ?i = x \ ?i < n" + by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce) + thus "xs ! ?i * col Q 0 $v ?i = col Q 0 $v ?i * x" by auto + qed + also have "... = (\x \ S. ?f x * x)" using set_xs by auto + finally show "\f. (\i\S. f i * i) = d" by auto + qed + moreover have "ideal_generated S \ ideal_generated {d}" + proof + fix x assume x: "x \ ideal_generated S" thm Matrix.diag_mat_def + hence x_xs: "x \ ideal_generated (set xs)" by (simp add: set_xs) + from this obtain f where f: "(\i\(set xs). f i * i) = x" using x ideal_explicit2 by auto + define B where "B = Matrix.vec n (\i. f (A $$ (0,i)))" + have B: "B \ carrier_vec n" unfolding B_def by auto + have "(A *\<^sub>v B) $v 0 = Matrix.row A 0 \ B" by (rule index_mult_mat_vec[OF a]) + also have "... = sum (\i. f (A $$ (0,i)) * A $$ (0,i)) {0..i. f i * i) (set xs)" + proof (rule sum.reindex_bij_betw) + have 1: "inj_on (\x. A $$ (0, x)) {0.. set xs" if xa: "xa < n" for xa + proof - + have "A $$ (0,xa) = [vec_of_list xs] ! 0 $v xa" + unfolding A_def by (rule mat_of_rows_index, insert xa, auto) + also have "... = xs ! xa" using xa by (simp add: vec_of_list_index) + finally show ?thesis using xa by (simp add: length_eq_card n_def) + qed + have 3: "x \ (\x. A $$ (0, x)) ` {0.. set xs" for x + proof - + obtain i where xs: "xs ! i = x \ i < n" + by (metis in_set_conv_nth length_eq_card n_def x) + have "A $$ (0,i) = [vec_of_list xs] ! 0 $v i" + unfolding A_def by (rule mat_of_rows_index, insert xs, auto) + also have "... = xs ! i" using xs by (simp add: vec_of_list_index) + finally show ?thesis using xs unfolding image_def by auto + qed + show "bij_betw (\x. A $$ (0, x)) {0..v B) $v 0 = sum (\i. f i * i) (set xs)" by auto + hence AB_00_x: "(A *\<^sub>v B) $v 0 = x" using f by auto + obtain Q' where QQ': "inverts_mat Q Q'" + and Q'Q: "inverts_mat Q' Q" and Q': "Q' \ carrier_mat n n" + by (rule obtain_inverse_matrix[OF Q inv_Q], auto) + have eq: "A = (A*Q)*Q'" using QQ' unfolding inverts_mat_def + by (metis A Q Q' assoc_mult_mat carrier_matD(1) right_mult_one_mat) + let ?g = "\i. Matrix.row (A * Q) 0 $v i * (Matrix.row Q' i \ B)" + have sum0: "(\i = 1.. {1.. B) = 0" by simp + qed + have set_rw: "{0..v B = A*Q*\<^sub>v(Q' *\<^sub>v B)" + by (rule assoc_mult_mat_vec, insert Q Q' B AQ, auto) + from eq have "A *\<^sub>vB = (A*Q)*\<^sub>v(Q'*\<^sub>v B)" using mat_rw by auto + from this have "(A *\<^sub>v B) $v 0 = (A * Q *\<^sub>v (Q' *\<^sub>v B)) $v 0" by auto + also have "... = Matrix.row (A*Q) 0 \ (Q' *\<^sub>v B)" + by (rule index_mult_mat_vec, insert a B_def n0, auto) + also have "... = (\i = 0..i \ {0..i = 1.. B)" by (simp add: a d_def q0) + finally show "x \ ideal_generated {d}" using AB_00_x unfolding ideal_generated_singleton + using mult.commute by auto + qed + ultimately show ?thesis by auto + qed + thus "principal_ideal I" unfolding principal_ideal_def ig_S by blast + qed +qed + +subsection \Elementary divisor ring implies Hermite ring\ + +context + assumes "SORT_CONSTRAINT('a::comm_ring_1)" +begin + + +lemma triangularizable_m0: +assumes A: "A \ carrier_mat m 0" +shows "\U. U \ carrier_mat 0 0 \ invertible_mat U \ lower_triangular (A * U)" + using A unfolding lower_triangular_def carrier_mat_def invertible_mat_def inverts_mat_def + by auto (metis gr_implies_not0 index_one_mat(2) index_one_mat(3) right_mult_one_mat') + +lemma triangularizable_0n: +assumes A: "A \ carrier_mat 0 n" +shows "\U. U \ carrier_mat n n \ invertible_mat U \ lower_triangular (A * U)" + using A unfolding lower_triangular_def carrier_mat_def invertible_mat_def inverts_mat_def + by auto (metis index_one_mat(2) index_one_mat(3) right_mult_one_mat') + + +(*To show this, we have to prove that P is a matrix of one element, which is a unit.*) +lemma diagonal_imp_triangular_1x2: + assumes A: "A \ carrier_mat 1 2" and d: "admits_diagonal_reduction (A::'a mat)" + shows "admits_triangular_reduction A" +proof - + obtain P Q where P: "P \ carrier_mat (dim_row A) (dim_row A)" + and Q: "Q \ carrier_mat (dim_col A) (dim_col A)" + and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q" + and SNF: "Smith_normal_form_mat (P * A * Q)" + using d unfolding admits_diagonal_reduction_def by blast + have "(P * A * Q) = P * (A * Q)" using P Q assoc_mult_mat by blast + also have "... = P $$ (0,0) \\<^sub>m (A * Q)" by (rule smult_mat_mat_one_element, insert P A Q, auto) + also have "... = A * (P $$ (0,0) \\<^sub>m Q)" using Q by auto + finally have eq: "(P * A * Q) = A * (P $$ (0,0) \\<^sub>m Q)" . + have inv: "invertible_mat (P $$ (0,0) \\<^sub>m Q)" + proof - + have d: "Determinant.det P = P $$ (0, 0)" by (rule determinant_one_element, insert P A, auto) + from this have P_dvd_1: "P $$ (0, 0) dvd 1" + using invertible_iff_is_unit_JNF[OF P] using inv_P by auto + have Q_dvd_1: "Determinant.det Q dvd 1" using inv_Q invertible_iff_is_unit_JNF[OF Q] by simp + have "Determinant.det (P $$ (0, 0) \\<^sub>m Q) = P $$ (0, 0) ^ dim_col Q * Determinant.det Q" + unfolding det_smult by auto + also have "... dvd 1" using P_dvd_1 Q_dvd_1 unfolding is_unit_mult_iff + by (metis dvdE dvd_mult_left one_dvd power_mult_distrib power_one) + finally have det: "(Determinant.det (P $$ (0, 0) \\<^sub>m Q) dvd 1)" . + have PQ: "P $$ (0,0) \\<^sub>m Q \ carrier_mat 2 2" using A P Q by auto + show ?thesis using invertible_iff_is_unit_JNF[OF PQ] det by auto + qed + moreover have "lower_triangular (A * (P $$ (0,0) \\<^sub>m Q))" unfolding lower_triangular_def using SNF eq + unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto + moreover have "(P $$ (0,0) \\<^sub>m Q) \ carrier_mat (dim_col A) (dim_col A)" using P Q A by auto + ultimately show ?thesis unfolding admits_triangular_reduction_def by auto +qed + +lemma triangular_imp_diagonal_1x2: +assumes A: "A \ carrier_mat 1 2" and t: "admits_triangular_reduction (A::'a mat)" +shows "admits_diagonal_reduction A" +proof - + obtain U where U: "U \ carrier_mat (dim_col A) (dim_col A)" + and inv_U: "invertible_mat U" and AU: "lower_triangular (A * U)" + using t unfolding admits_triangular_reduction_def by blast + have SNF_AU: "Smith_normal_form_mat (A * U)" + using AU A unfolding Smith_normal_form_mat_def lower_triangular_def isDiagonal_mat_def by auto + have "A * U = (1\<^sub>m 1) * A * U" using A by auto + hence SNF: "Smith_normal_form_mat ((1\<^sub>m 1) * A * U)" using SNF_AU by auto + moreover have "invertible_mat (1\<^sub>m 1)" + using invertible_mat_def inverts_mat_def by fastforce + ultimately show ?thesis using inv_U unfolding admits_diagonal_reduction_def + by (smt U assms(1) carrier_matD(1) one_carrier_mat) +qed + + +lemma triangular_eq_diagonal_1x2: + "(\A\carrier_mat 1 2. admits_triangular_reduction (A::'a mat)) + = (\A\carrier_mat 1 2. admits_diagonal_reduction (A::'a mat))" + using triangular_imp_diagonal_1x2 diagonal_imp_triangular_1x2 by auto + + +lemma admits_triangular_mat_1x1: + assumes A: "A \ carrier_mat 1 1" + shows "admits_triangular_reduction (A::'a mat)" + by (rule admits_triangular_reduction_intro[of "1\<^sub>m 1"], insert A, + auto simp add: admits_triangular_reduction_def lower_triangular_def) + + +lemma admits_diagonal_mat_1x1: + assumes A: "A \ carrier_mat 1 1" + shows "admits_diagonal_reduction (A::'a mat)" + by (rule admits_diagonal_reduction_intro[of "(1\<^sub>m 1)" _ "(1\<^sub>m 1)"], + insert A, auto simp add: Smith_normal_form_mat_def isDiagonal_mat_def) + + +lemma admits_diagonal_imp_admits_triangular_1xn: + assumes a: "\A\carrier_mat 1 2. admits_diagonal_reduction (A::'a mat)" + shows "\A\carrier_mat 1 n. admits_triangular_reduction (A::'a mat)" +proof + fix A::"'a mat" assume A: "A \ carrier_mat 1 n" + have "\U. U \ carrier_mat (dim_col A) (dim_col A) + \ invertible_mat U \ lower_triangular (A * U)" (*Zeros above the diagonal*) + using A + proof (induct n arbitrary: A rule: less_induct) + case (less n) + note A = less.prems(1) + show ?case + proof (cases "n=0") + case True + then show ?thesis using triangularizable_m0 triangularizable_0n less.prems by auto + next + case False note nm_not_0 = False + from this have n_not_0: "n \ 0" by auto + show ?thesis + proof (cases "n>2") + case False note n_less_2 = False + show ?thesis using admits_triangular_mat_1x1 a diagonal_imp_triangular_1x2 + unfolding admits_triangular_reduction_def + by (metis (full_types) admits_triangular_mat_1x1 Suc_1 admits_triangular_reduction_def + less(2) less_Suc_eq less_one linorder_neqE_nat n_less_2 nm_not_0 triangular_eq_diagonal_1x2) + next + case True note n_ge_2 = True + let ?B = "mat_of_row (vec_last (Matrix.row A 0) (n - 1))" + have "\V. V\ carrier_mat (dim_col ?B) (dim_col ?B) + \ invertible_mat V \ lower_triangular (?B * V)" + proof (rule less.hyps) + show "n-1 < n" using n_not_0 by auto + show "mat_of_row (vec_last (Matrix.row A 0) (n - 1)) \ carrier_mat 1 (n - 1)" + using A by simp + qed + from this obtain V where inv_V: "invertible_mat V" and BV: "lower_triangular (?B * V)" + and V': "V \ carrier_mat (dim_col ?B) (dim_col ?B)" + by fast + have V: "V \ carrier_mat (n-1) (n-1)" using V' by auto + have BV_0: "\j \ {1..(i,j). if i=0 \ j=0 then a else b)" + have ab[simp]: "ab \ carrier_mat 1 2" unfolding ab_def by simp + hence "admits_diagonal_reduction ab" using a by auto + hence "admits_triangular_reduction ab" using diagonal_imp_triangular_1x2[OF ab] by auto + from this obtain W where inv_W: "invertible_mat W" and ab_W: "lower_triangular (ab * W)" + and W: "W \ carrier_mat 2 2" + unfolding admits_triangular_reduction_def using ab by auto + have id_n2_carrier[simp]: "1\<^sub>m (n-2) \ carrier_mat (n-2) (n-2)" by auto + define U where "U = (four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (n-1)) (0\<^sub>m (n-1) 1) V) * + (four_block_mat W (0\<^sub>m 2 (n-2)) (0\<^sub>m (n-2) 2) (1\<^sub>m (n-2)))" + let ?U1 = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (n-1)) (0\<^sub>m (n-1) 1) V" + let ?U2 = "four_block_mat W (0\<^sub>m 2 (n-2)) (0\<^sub>m (n-2) 2) (1\<^sub>m (n-2))" + have U1[simp]: "?U1 \carrier_mat n n" using four_block_carrier_mat[OF _ V] nm_not_0 + by fastforce + have U2[simp]: "?U2 \carrier_mat n n" using four_block_carrier_mat[OF W id_n2_carrier] + by (metis True add_diff_inverse_nat less_imp_add_positive not_add_less1) + have U[simp]: "U \ carrier_mat n n" unfolding U_def using U1 U2 by auto + moreover have inv_U: "invertible_mat U" + proof - + have "invertible_mat ?U1" + by (metis U1 V det_four_block_mat_lower_left_zero_col det_one inv_V + invertible_iff_is_unit_JNF more_arith_simps(5) one_carrier_mat zero_carrier_mat) + moreover have "invertible_mat ?U2" + proof - + have "Determinant.det ?U2 = Determinant.det W" + by (rule det_four_block_mat_lower_right_id, insert less.prems W n_ge_2, auto) + also have " ... dvd 1" + using W inv_W invertible_iff_is_unit_JNF by auto + finally show ?thesis using invertible_iff_is_unit_JNF[OF U2] by auto + qed + ultimately show ?thesis + using U1 U2 U_def invertible_mult_JNF by blast + qed + moreover have "lower_triangular (A*U)" + proof - + let ?A = "Matrix.mat 1 n (\(i,j). if j = 0 then a else if j=1 then b else 0)" + let ?T = "Matrix.mat 1 n (\(i,j). if j = 0 then (ab*W) $$ (0,0) else 0)" + have "A*?U1 = ?A" + proof (rule eq_matI) + fix i j assume i: "i col ?U1 j" + by (rule index_mult_mat, insert i j A V, auto) + also have "... = (\i = 0..i. i+1)`{0..i. i+1)`{0.. (\i. i+1)) {0.. col V (j-1)" unfolding scalar_prod_def + proof (rule sum.cong) + fix x assume x: "x \ {0..A\carrier_mat 1 2. admits_diagonal_reduction (A::'a mat)" + shows "\A. admits_triangular_reduction (A::'a mat)" +proof + fix A::"'a mat" + obtain m n where A: "A \ carrier_mat m n" by auto + have "\U. U \ carrier_mat n n \ invertible_mat U \ lower_triangular (A * U)" (*Zeros above the diagonal*) + using A + proof (induct n arbitrary: m A rule: less_induct) + case (less n) + note A = less.prems(1) + show ?case + proof (cases "n=0 \ m=0") + case True + then show ?thesis using triangularizable_m0 triangularizable_0n less.prems by auto + next + case False note nm_not_0 = False + from this have m_not_0: "m \ 0" and n_not_0: "n \ 0" by auto + show ?thesis + proof (cases "m = 1") + case True note m1 = True + show ?thesis using admits_diagonal_imp_admits_triangular_1xn A m1 a + unfolding admits_triangular_reduction_def by blast + next + case False note m_not_1 = False + (* The article says "Right-multiply A by a unimodular matrix V which reduces the first row. + To do that, I use the first case of the induction (m=1) to reduce the first row. + With lemma mult_eq_first_row I will show that A*V reduces the first row. + *) + show ?thesis + proof (cases "n=1") + case True + thus ?thesis using invertible_mat_zero lower_triangular_def + by (metis carrier_matD(2) det_one gr_implies_not0 invertible_iff_is_unit_JNF less(2) + less_one one_carrier_mat right_mult_one_mat') + next + case False note n_not_1 = False + let ?first_row = "mat_of_row (Matrix.row A 0)" + have first_row: "?first_row \ carrier_mat 1 n" using less.prems by auto + have m1: "m>1" using m_not_1 m_not_0 by linarith + have n1: "n>1" using n_not_1 n_not_0 by linarith + obtain V where lt_first_row_V: "lower_triangular (?first_row * V)" + and inv_V: "invertible_mat V" and V: "V \ carrier_mat n n" + (*Using the other induction case*) + using admits_diagonal_imp_admits_triangular_1xn a first_row + unfolding admits_triangular_reduction_def by blast + have AV: "A*V \ carrier_mat m n" using V less by auto + have dim_row_AV: "dim_row (A * V) = 1 + (m-1)" using m1 AV by auto + have dim_col_AV: "dim_col (A * V) = 1 + (n-1)" using n1 AV by fastforce + have reduced_first_row: "Matrix.row (?first_row * V) 0 = Matrix.row (A * V) 0" + by (rule mult_eq_first_row, insert first_row m1 less.prems, auto) + obtain a zero B C where split: "split_block (A*V) 1 1 = (a, zero, B, C)" + using prod_cases4 by blast + have a: "a \ carrier_mat 1 1" and zero: "zero \ carrier_mat 1 (n-1)" and + B: "B \ carrier_mat (m-1) 1" and C: "C \ carrier_mat (m-1) (n-1)" + by (rule split_block[OF split dim_row_AV dim_col_AV])+ + have AV_block: "A*V = four_block_mat a zero B C" + by (rule split_block[OF split dim_row_AV dim_col_AV]) + have "\W. W\ carrier_mat (n-1) (n-1) \ invertible_mat W \ lower_triangular (C*W)" + by (rule less.hyps, insert n1 C, auto) + from this obtain W where inv_W: "invertible_mat W" and lt_CW: "lower_triangular (C*W)" + and W: "W \ carrier_mat (n-1) (n-1)" by blast + let ?W2 = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (n-1)) (0\<^sub>m (n-1) 1) W" + have W2: "?W2 \ carrier_mat n n" using V W dim_col_AV by auto + have "Determinant.det ?W2 = Determinant.det (1\<^sub>m 1) * Determinant.det W" + by (rule det_four_block_mat_lower_left_zero_col[OF _ _ _ W], auto) + hence det_W2: "Determinant.det ?W2 = Determinant.det W" by auto + hence inv_W2: "invertible_mat ?W2" + by (metis W four_block_carrier_mat inv_W invertible_iff_is_unit_JNF one_carrier_mat) + have inv_V_W2: "invertible_mat (V * ?W2)" using inv_W2 inv_V V W2 invertible_mult_JNF by blast + have "lower_triangular (A*V*?W2)" + proof - + let ?T = "(four_block_mat a (0\<^sub>m 1 (n-1)) B (C * W))" + have zero_eq: "zero = 0\<^sub>m 1 (n-1)" + proof (rule eq_matI) + show 1: "dim_row zero = dim_row (0\<^sub>m 1 (n - 1))" and 2: "dim_col zero = dim_col (0\<^sub>m 1 (n - 1))" + using zero by auto + fix i j assume i: "i < dim_row (0\<^sub>m 1 (n - 1))" and j: "j < dim_col (0\<^sub>m 1 (n - 1))" + have i0: "i=0" using i by auto + have "0 = Matrix.row (?first_row * V) 0 $v (j+1)" + using lt_first_row_V j unfolding lower_triangular_def + by (metis Suc_eq_plus1 carrier_matD(2) index_mult_mat(2,3) index_row(1) less_diff_conv + mat_of_row_dim(1) zero zero_less_Suc zero_less_one_class.zero_less_one V 2) + also have "... = Matrix.row (A*V) 0 $v (j+1)" by (simp add: reduced_first_row) + also have "... = (A*V) $$ (i, j+1)" using V dim_row_AV i0 j by auto + also have "... = four_block_mat a zero B C $$ (i, j+1)" by (simp add: AV_block) + also have "... = (if i < dim_row a then if (j+1) < dim_col a + then a $$ (i, (j+1)) else zero $$ (i, (j+1) - dim_col a) else if (j+1) < dim_col a + then B $$ (i - dim_row a, (j+1)) else C $$ (i - dim_row a, (j+1) - dim_col a))" + by (rule index_mat_four_block, insert a zero i j C, auto) + also have "... = zero $$ (i, (j+1) - dim_col a)" using a zero i j C by auto + also have "... = zero $$ (i, j)" using a i by auto + finally show "zero $$ (i, j) = 0\<^sub>m 1 (n - 1) $$ (i, j)" using i j by auto + qed + have rw1: "a * (1\<^sub>m 1) + zero * (0\<^sub>m (n-1) 1) = a" using a zero by auto + have rw2: "a * (0\<^sub>m 1 (n-1)) + zero * W = 0\<^sub>m 1 (n-1)" using a zero zero_eq W by auto + have rw3: "B * (1\<^sub>m 1) + C * (0\<^sub>m (n-1) 1) = B" using B C by auto + have rw4: "B * (0\<^sub>m 1 (n-1)) + C * W = C * W" using B C W by auto + have "A*V = four_block_mat a zero B C" by (rule AV_block) + also have "... * ?W2 = four_block_mat (a * (1\<^sub>m 1) + zero * (0\<^sub>m (n-1) 1)) + (a * (0\<^sub>m 1 (n-1)) + zero * W) (B * (1\<^sub>m 1) + C * (0\<^sub>m (n-1) 1)) + (B * (0\<^sub>m 1 (n-1)) + C * W)" by (rule mult_four_block_mat[OF a zero B C], insert W, auto) + also have "... = ?T" using rw1 rw2 rw3 rw4 by simp + finally have AVW2: "A*V * ?W2 = ..." . + moreover have "lower_triangular ?T" + using lt_CW unfolding lower_triangular_def using a zero B C W + by (auto, metis (full_types) Suc_less_eq Suc_pred basic_trans_rules(19)) + ultimately show ?thesis by simp + qed + then show ?thesis using inv_V_W2 V W2 less.prems + by (smt assoc_mult_mat mult_carrier_mat) + qed + qed + qed + qed + thus "admits_triangular_reduction A" using A unfolding admits_triangular_reduction_def by simp +qed + +corollary admits_diagonal_imp_admits_triangular': + assumes a: "\A. admits_diagonal_reduction (A::'a mat)" + shows "\A. admits_triangular_reduction (A::'a mat)" + using admits_diagonal_imp_admits_triangular assms by blast + + +lemma admits_triangular_reduction_1x2: + assumes "\A::'a mat. A \ carrier_mat 1 2 \ admits_triangular_reduction A" + shows "\C::'a mat. admits_triangular_reduction C" + using admits_diagonal_imp_admits_triangular assms triangular_eq_diagonal_1x2 by auto + + +lemma Hermite_ring_OFCLASS: + assumes "\A \ carrier_mat 1 2. admits_triangular_reduction (A::'a mat)" + shows "OFCLASS('a, Hermite_ring_class)" +proof + show "\A::'a mat. admits_triangular_reduction A" + by (rule admits_diagonal_imp_admits_triangular[OF assms[unfolded triangular_eq_diagonal_1x2]]) +qed + +lemma Hermite_ring_OFCLASS': + assumes "\A \ carrier_mat 1 2.admits_diagonal_reduction (A::'a mat)" + shows "OFCLASS('a, Hermite_ring_class)" +proof + show "\A::'a mat. admits_triangular_reduction A" + by (rule admits_diagonal_imp_admits_triangular[OF assms]) +qed + +lemma theorem3_part1: + assumes T: "(\a b::'a. \ a1 b1 d. a = a1*d \ b = b1*d + \ ideal_generated {a1,b1} = ideal_generated {1})" + shows "\A::'a mat. admits_triangular_reduction A" +proof (rule admits_triangular_reduction_1x2, rule allI, rule impI) + fix A::"'a mat" + assume A: "A \ carrier_mat 1 2" + let ?a = "A $$ (0,0)" + let ?b = "A $$ (0,1)" + obtain a1 b1 d where a: "?a = a1*d" and b: "?b = b1*d" + and i: "ideal_generated {a1,b1} = ideal_generated {1}" + using T by blast + obtain s t where sa1tb1:"s*a1+t*b1=1" using ideal_generated_pair_exists_pq1[OF i[simplified]] by blast + let ?Q = "Matrix.mat 2 2 (\(i,j). if i = 0 \ j = 0 then s else + if i = 0 \ j = 1 then -b1 else + if i = 1 \ j = 0 then t else a1)" + have Q: "?Q \ carrier_mat 2 2" by auto + have det_Q: "Determinant.det ?Q = 1" unfolding det_2[OF Q] + using sa1tb1 by (simp add: mult.commute) + hence inv_Q: "invertible_mat ?Q" using invertible_iff_is_unit_JNF[OF Q] by auto + have lower_AQ: "lower_triangular (A*?Q)" + proof - + have "Matrix.row A 0 $v Suc 0 * a1 = Matrix.row A 0 $v 0 * b1" if j2: "j<2" and j0: "0A::'a mat. admits_triangular_reduction A" + shows "\a b::'a. \ a1 b1 d. a = a1*d \ b = b1*d \ ideal_generated {a1,b1} = ideal_generated {1}" +proof (rule allI)+ + fix a b::'a + let ?A = "Matrix.mat 1 2 (\(i,j). if i = 0 \ j = 0 then a else b)" + obtain Q where AQ: "lower_triangular (?A*Q)" and inv_Q: "invertible_mat Q" + and Q: "Q \ carrier_mat 2 2" + using 1 unfolding admits_triangular_reduction_def by fastforce + hence [simp]: "dim_col Q = 2" and [simp]: "dim_row Q = 2" by auto + let ?s = "Q $$ (0,0)" + let ?t = "Q $$ (1,0)" + let ?a1 = "Q $$ (1,1)" + let ?b1 = "-(Q $$ (0,1))" + let ?d = "(?A*Q) $$ (0,0)" + have ab1_ba1: "a*?b1 = b*?a1" + proof - + have "(?A*Q) $$ (0,1) = (\i = 0..<2. (if i = 0 then a else b) * Q $$ (i, Suc 0))" + unfolding times_mat_def col_def scalar_prod_def by auto + also have "... = (\i \ {0,1}. (if i = 0 then a else b) * Q $$ (i, Suc 0))" + by (rule sum.cong, auto) + also have "... = - a*?b1 + b*?a1" by auto + finally have "(?A*Q) $$ (0,1) = - a*?b1 + b*?a1" by simp + moreover have "(?A*Q) $$ (0,1) = 0" using AQ unfolding lower_triangular_def by auto + ultimately show ?thesis + by (metis add_left_cancel more_arith_simps(3) more_arith_simps(7)) + qed + have sa_tb_d: "?s*a+?t*b = ?d" + proof - + have "?d = (\i = 0..<2. (if i = 0 then a else b) * Q $$ (i, 0))" + unfolding times_mat_def col_def scalar_prod_def by auto + also have "... = (\i \ {0,1}. (if i = 0 then a else b) * Q $$ (i, 0))" by (rule sum.cong, auto) + also have "... = ?s*a+?t*b" by auto + finally show ?thesis by simp + qed + have det_Q_dvd_1: "(Determinant.det Q dvd 1)" + using invertible_iff_is_unit_JNF[OF Q] inv_Q by auto + moreover have det_Q_eq: "Determinant.det Q = ?s*?a1 + ?t*?b1" unfolding det_2[OF Q] by simp + ultimately have "?s*?a1 + ?t*?b1 dvd 1" by auto + from this obtain u where u_eq: "?s*?a1 + ?t*?b1 = u" and u: "u dvd 1" by auto + hence eq1: "?s*?a1*a + ?t*?b1*a = u*a" + by (metis ring_class.ring_distribs(2)) + hence "?s*?a1*a + ?t*?a1*b = u*a" + by (metis (no_types, lifting) ab1_ba1 mult.assoc mult.commute) + hence a1d_ua:"?a1*?d=u*a" + by (smt Groups.mult_ac(2) distrib_left more_arith_simps(11) sa_tb_d) + hence b1d_ub: "?b1*?d=u*b" + by (smt Groups.mult_ac(2) Groups.mult_ac(3) ab1_ba1 distrib_right sa_tb_d u_eq) + obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def + by (metis mult.commute) + hence inv_u_dvd_1: "inv_u dvd 1" unfolding dvd_def by auto + have cond1: "(inv_u*?b1)*?d = b" using b1d_ub inv_u + by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6)) + have cond2: "(inv_u*?a1)*?d = a" using a1d_ua inv_u + by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6)) + have "ideal_generated {inv_u*?a1, inv_u*?b1} = ideal_generated {?a1,?b1}" + by (rule ideal_generated_mult_unit2[OF inv_u_dvd_1]) + also have "... = UNIV" using ideal_generated_pair_UNIV[OF u_eq u] by simp + finally have cond3: "ideal_generated {inv_u*?a1, inv_u*?b1} = ideal_generated {1}" by auto + show "\a1 b1 d. a = a1 * d \ b = b1 * d \ ideal_generated {a1, b1} = ideal_generated {1}" + by (rule exI[of _ "inv_u*?a1"], rule exI[of _ "inv_u*?b1"], rule exI[of _ ?d], + insert cond1 cond2 cond3, auto) +qed + + +theorem theorem3: + shows "(\A::'a mat. admits_triangular_reduction A) + = (\a b::'a. \ a1 b1 d. a = a1*d \ b = b1*d \ ideal_generated {a1,b1} = ideal_generated {1})" + using theorem3_part1 theorem3_part2 by auto + +end + + + +context comm_ring_1 +begin + + +lemma lemma4_prev: + assumes a: "a = a1*d" and b: "b = b1*d" + and i: "ideal_generated {a1,b1} = ideal_generated {1}" +shows "ideal_generated {a,b} = ideal_generated {d}" +proof - + have 1: "\k. p * (a1 * d) + q * (b1 * d) = k * d" for p q + by (metis (full_types) local.distrib_right local.mult.semigroup_axioms semigroup.assoc) + have "ideal_generated {a,b} \ ideal_generated {d}" + proof - + have "ideal_generated {a,b} = {p*a+q*b | p q. True}" using ideal_generated_pair by auto + also have "... = {p*(a1*d)+q*(b1*d) | p q. True}" using a b by auto + also have "... \ {k*d|k. True}" using 1 by auto + finally show ?thesis + by (simp add: a b local.dvd_ideal_generated_singleton' local.ideal_generated_subset2) + qed + moreover have "ideal_generated{d} \ ideal_generated {a,b}" + proof (rule ideal_generated_singleton_subset) + obtain p q where "p*a1+q*b1 = 1" using ideal_generated_pair_exists_UNIV i by auto + hence "d = p * (a1 * d) + q * (b1 * d)" + by (metis local.mult_ac(3) local.ring_distribs(1) local.semiring_normalization_rules(12)) + also have "... \ {p*(a1*d)+q*(b1*d) | p q. True}" by auto + also have "... = ideal_generated {a,b}" unfolding ideal_generated_pair a b by auto + finally show "d \ ideal_generated {a,b}" by simp + qed (simp) + ultimately show ?thesis by simp +qed + + +lemma lemma4: + assumes a: "a = a1*d" and b: "b = b1*d" + and i: "ideal_generated {a1,b1} = ideal_generated {1}" + and i2: "ideal_generated {a,b} = ideal_generated {d'}" + shows "\a1' b1'. a = a1' * d' \ b = b1' * d' + \ ideal_generated {a1',b1'} = ideal_generated {1}" +proof - + have i3: "ideal_generated {a,b} = ideal_generated {d}" using lemma4_prev assms by auto + have d_dvd_d': "d dvd d'" + by (metis a b i2 dvd_ideal_generated_singleton dvd_ideal_generated_singleton' + dvd_triv_right ideal_generated_subset2) + have d'_dvd_d: "d' dvd d" + using i3 i2 local.dvd_ideal_generated_singleton by auto + obtain k and l where d: "d = k*d'" and d': "d' = l*d" + using d_dvd_d' d'_dvd_d mult_ac unfolding dvd_def by auto + obtain s t where sa1_tb1: "s*a1 + t*b1 = 1" + using i ideal_generated_pair_exists_UNIV[of a1 b1] by auto + let ?a1' = "k * l * t - t + a1 * k" + let ?b1' = "s - k * l * s + b1 * k" + have 1: "?a1'*d'=a" + by (metis a d d' add_ac(2) add_diff_cancel add_diff_eq mult_ac(2) ring_distribs(1,4) + semiring_normalization_rules(18)) + have 2: "?b1'*d' = b" + by (metis (no_types, hide_lams) b d d' add_ac(2) add_diff_cancel add_diff_eq mult_ac(2) mult_ac(3) + ring_distribs(2,4) semiring_normalization_rules(18)) + have "(s*l-b1)*?a1' + (t*l+a1)*?b1' = 1" + proof - + have aux_rw1: "s * l * k * l * t = t * l * k * l * s" and aux_rw2: "s * l * t=t * l * s" + and aux_rw3: "b1 * a1 * k=a1 * b1 * k" and aux_rw4: "t * l * b1 * k=b1 * k * l * t" + and aux_rw5: "s * l * a1 * k=a1 * k * l * s" + using mult.commute mult.assoc by auto + note aux_rw = aux_rw1 aux_rw2 aux_rw3 aux_rw4 aux_rw5 + have "(s*l-b1)*?a1' + (t*l+a1)*?b1' = s*l*?a1' - b1*?a1' + t*l*?b1'+a1*?b1'" + using local.add_ac(1) local.left_diff_distrib' local.ring_distribs(2) by auto + also have "... = s * l * k * l*t - s * l * t + s * l * a1 * k-b1 * k * l * t + b1 * t-b1 * a1 * k + + t * l * s-t * l * k * l * s + t * l * b1 * k + a1 * s - a1 * k * l * s + a1 * b1 * k" + by (smt abel_semigroup.commute add.abel_semigroup_axioms diff_add_eq diff_diff_eq2 + mult.semigroup_axioms ring_distribs(4) semiring_normalization_rules(34) semigroup.assoc) + also have "... = a1 * s + b1 * t" unfolding aux_rw + by (smt add_ac(2) add_ac(3) add_minus_cancel ring_distribs(4) ring_normalization_rules(2)) + also have "... = 1" using sa1_tb1 mult.commute by auto + finally show ?thesis by simp + qed + hence "ideal_generated {?a1',?b1'} = ideal_generated {1}" + using ideal_generated_pair_exists_UNIV[of ?a1' ?b1'] by auto + thus ?thesis using 1 2 by auto +qed + + +(*In the article, this is a corollary. But here, this needs more work.*) +lemma corollary5: + assumes T: "\a b. \a1 b1 d. a = a1 * d \ b = b1 * d + \ ideal_generated {a1, b1} = ideal_generated {1::'a}" + and i2: "ideal_generated {a,b,c} = ideal_generated {d}" + shows "\ a1 b1 c1. a = a1 * d \ b = b1 * d \ c = c1 * d + \ ideal_generated {a1,b1,c1} = ideal_generated {1}" +proof - + have da: "d dvd a" using ideal_generated_singleton_dvd[OF i2] by auto + have db: "d dvd b" using ideal_generated_singleton_dvd[OF i2] by auto + have dc: "d dvd c" using ideal_generated_singleton_dvd[OF i2] by auto + from this obtain c1' where c: "c = c1' * d" using dvd_def mult_ac(2) by auto + obtain a1 b1 d' where a: "a = a1 * d'" and b: "b = b1 * d' " + and i: "ideal_generated {a1, b1} = ideal_generated {1::'a}" using T by blast + have i_ab_d': "ideal_generated {a, b} = ideal_generated {d'}" + by (simp add: a b i lemma4_prev) + have i2: "ideal_generated {d', c} = ideal_generated {d}" + by (rule ideal_generated_triple_pair_rewrite[OF i2 i_ab_d']) + obtain u v dp where d'1: "d' = u * dp" and d'2: "c = v * dp" + and xy: "ideal_generated{u,v}=ideal_generated{1}" using T by blast + have "\a1' b1'. d' = a1' * d \ c = b1' * d \ ideal_generated {a1', b1'} = ideal_generated {1}" + by (rule lemma4[OF d'1 d'2 xy i2]) + from this obtain a1' c1 where d'_a1: "d' = a1' * d" and c: "c = c1 * d" + and i3: "ideal_generated {a1', c1} = ideal_generated {1}" by blast + have r1: "a = a1 * a1' * d" by (simp add: d'_a1 a local.semiring_normalization_rules(18)) + have r2: "b = b1 * a1' * d" by (simp add: d'_a1 b local.semiring_normalization_rules(18)) + have i4: "ideal_generated {a1 * a1',b1 * a1', c1} = ideal_generated {1}" + proof - + obtain p q where 1: "p * a1' + q * c1 = 1" + using i3 unfolding ideal_generated_pair_exists_UNIV by auto + obtain x y where 2: "x*a1 + y*b1 = p" using ideal_generated_UNIV_obtain_pair[OF i] by blast + have "1 = (x*a1 + y*b1) * a1' + q * c1" using 1 2 by auto + also have "... = x*a1*a1' + y*b1*a1' + q * c1" by (simp add: local.ring_distribs(2)) + finally have "1 = x*a1*a1' + y*b1*a1' + q * c1" . + hence "1 \ ideal_generated {a1 * a1', b1 * a1', c1}" + using ideal_explicit2[of "{a1 * a1', b1 * a1', c1}"] sum_three_elements' + by (simp add: mult_assoc) + hence "ideal_generated {1} \ ideal_generated {a1 * a1',b1 * a1', c1}" + by (rule ideal_generated_singleton_subset, auto) + thus ?thesis by auto + qed + show ?thesis using r1 r2 i4 c by auto +qed + + +end + +context + assumes "SORT_CONSTRAINT('a::comm_ring_1)" +begin + +lemma OFCLASS_elementary_divisor_ring_imp_class: + assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class)" + shows " class.elementary_divisor_ring TYPE('a)" + by (rule conjunctionD2[OF assms[unfolded elementary_divisor_ring_class_def]]) + + +(*ELEMENTARY DIVISOR RING \ HERMITE*) +corollary Elementary_divisor_ring_imp_Hermite_ring: + assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class) " + shows "OFCLASS('a::comm_ring_1, Hermite_ring_class)" +proof + have "\A::'a mat. admits_diagonal_reduction A" + using OFCLASS_elementary_divisor_ring_imp_class[OF assms] + unfolding class.elementary_divisor_ring_def by auto + thus "\A::'a mat. admits_triangular_reduction A" + using admits_diagonal_imp_admits_triangular by auto +qed + +(*ELEMENTARY DIVISOR RING \ BEZOUT*) +corollary Elementary_divisor_ring_imp_Bezout_ring: + assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class) " + shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" + by (rule Hermite_ring_imp_Bezout_ring, rule Elementary_divisor_ring_imp_Hermite_ring[OF assms]) + +subsection \Characterization of Elementary divisor rings\ + +lemma necessity_D': + assumes edr: "(\(A::'a mat). admits_diagonal_reduction A)" + shows "\a b c::'a. ideal_generated {a,b,c} = ideal_generated{1} + \ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})" +proof ((rule allI)+, rule impI) + fix a b c::'a + assume i: "ideal_generated {a,b,c} = ideal_generated{1}" + define A where "A = Matrix.mat 2 2 (\(i,j). if i = 0 \ j = 0 then a else + if i = 0 \ j = 1 then b else + if i = 1 \ j = 0 then 0 else c)" + have A: "A \ carrier_mat 2 2" unfolding A_def by auto + obtain P Q where P: "P \ carrier_mat (dim_row A) (dim_row A)" + and Q: "Q \ carrier_mat (dim_col A) (dim_col A)" + and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q" + and SNF_PAQ: "Smith_normal_form_mat (P * A * Q)" + using edr unfolding admits_diagonal_reduction_def by blast + have [simp]: "dim_row P = 2" and [simp]: "dim_col P = 2 " and [simp]: "dim_row Q = 2" + and [simp]: "dim_col Q = 2" and [simp]: "dim_col A = 2" and [simp]: "dim_row A = 2" + using A P Q by auto + define u where "u = (P*A*Q) $$ (0,0)" + define p where "p = P $$ (0,0)" + define q where "q = P $$ (0,1)" + define x where "x = Q $$ (0,0)" + define y where "y = Q $$ (1,0)" + have eq: "p*a*x + p*b*y + q*c*y = u" + proof - + have rw1: "(\ia = 0..<2. P $$ (0, ia) * A $$ (ia, x)) * Q $$ (x, 0) + = (\ia\{0, 1}. P $$ (0, ia) * A $$ (ia, x)) * Q $$ (x, 0)" + for x by (unfold sum_distrib_right, rule sum.cong, auto) + have "u = (\i = 0..<2. (\ia = 0..<2. P $$ (0, ia) * A $$ (ia, i)) * Q $$ (i, 0))" + unfolding u_def p_def q_def x_def y_def + unfolding times_mat_def scalar_prod_def by auto + also have "... = (\i \{0,1}. (\ia \ {0,1}. P $$ (0, ia) * A $$ (ia, i)) * Q $$ (i, 0))" + by (rule sum.cong[OF _ rw1], auto) + also have "... = p*a*x + p*b*y+q*c*y" + unfolding u_def p_def q_def x_def y_def A_def + using ring_class.ring_distribs(2) by auto + finally show ?thesis .. + qed + have u_dvd_1: "u dvd 1" + (* + The article deduces this fact since u divides all the elements of the matrix A. Here, this is + already proved using GCD and minors, but it requires the semiring_GCD class. + At the end, I proved this fact by means of matrix multiplications once the inverse matrices of P + and Q are obtained. + *) + proof (rule ideal_generated_dvd2[OF i]) + define D where "D = (P*A*Q)" + obtain P' where P'[simp]: "P' \ carrier_mat 2 2" and inv_P: "inverts_mat P' P" + using inv_P obtain_inverse_matrix[OF P inv_P] + by (metis \dim_row A = 2\) + obtain Q' where [simp]: "Q' \ carrier_mat 2 2" and inv_Q: "inverts_mat Q Q'" + using inv_Q obtain_inverse_matrix[OF Q inv_Q] + by (metis \dim_col A = 2\) + have D[simp]: "D \ carrier_mat 2 2" unfolding D_def by auto + have e: "P' * D * Q' = A" unfolding D_def by (rule inv_P'PAQQ'[OF _ _ inv_P inv_Q], auto) + have [simp]: "(P' * D) \ carrier_mat 2 2" using D P' mult_carrier_mat by blast + have D_01: "D $$ (0, 1) = 0" + using D_def SNF_PAQ unfolding Smith_normal_form_mat_def isDiagonal_mat_def by force + have D_10: "D $$ (1, 0) = 0" + using D_def SNF_PAQ unfolding Smith_normal_form_mat_def isDiagonal_mat_def by force + have "D $$ (0,0) dvd D $$ (1, 1)" + using D_def SNF_PAQ unfolding Smith_normal_form_mat_def by auto + from this obtain k where D11: "D $$ (1, 1) = D $$ (0,0) * k" unfolding dvd_def by blast + have P'D_00: "(P' * D) $$ (0, 0) = P' $$ (0, 0) * D $$ (0, 0)" + using mat_mult2_00[of P' D] D_10 by auto + have P'D_01: "(P' * D) $$ (0, 1) = P' $$ (0, 1) * D $$ (1, 1)" + using mat_mult2_01[of P' D] D_01 by auto + have P'D_10: "(P' * D) $$ (1, 0) = P' $$ (1, 0) * D $$ (0, 0)" + using mat_mult2_10[of P' D] D_10 by auto + have P'D_11: "(P' * D) $$ (1, 1) = P' $$ (1, 1) * D $$ (1, 1)" + using mat_mult2_11[of P' D] D_01 by auto + have "a = (P' * D * Q') $$ (0,0)" using e A_def by auto + also have "... = (P' * D) $$ (0, 0) * Q' $$ (0, 0) + (P' * D) $$ (0, 1) * Q' $$ (1, 0)" + by (rule mat_mult2_00, auto) + also have "... = P' $$ (0, 0) * D $$ (0, 0) * Q' $$ (0, 0) + + P' $$ (0, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 0)" unfolding P'D_00 P'D_01 D11 .. + also have "... = D $$ (0, 0) * (P' $$ (0, 0) * Q' $$ (0, 0) + + P' $$ (0, 1) * k * Q' $$ (1, 0))" by (simp add: distrib_left) + finally have u_dvd_a: "u dvd a" unfolding u_def D_def dvd_def by auto + have "b = (P' * D * Q') $$ (0,1)" using e A_def by auto + also have "... = (P' * D) $$ (0, 0) * Q' $$ (0, 1) + (P' * D) $$ (0, 1) * Q' $$ (1, 1)" + by (rule mat_mult2_01, auto) + also have "... = P' $$ (0, 0) * D $$ (0, 0) * Q' $$ (0, 1) + + P' $$ (0, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 1)" + unfolding P'D_00 P'D_01 D11 .. + also have "... = D $$ (0, 0) * (P' $$ (0, 0) * Q' $$ (0, 1) + + P' $$ (0, 1) * k * Q' $$ (1, 1))" by (simp add: distrib_left) + finally have u_dvd_b: "u dvd b" unfolding u_def D_def dvd_def by auto + have "c = (P' * D * Q') $$ (1,1)" using e A_def by auto + also have "... = (P' * D) $$ (1, 0) * Q' $$ (0, 1) + (P' * D) $$ (1, 1) * Q' $$ (1, 1)" + by (rule mat_mult2_11, auto) + also have "... = P' $$ (1, 0) * D $$ (0, 0) * Q' $$ (0, 1) + + P' $$ (1, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 1)" unfolding P'D_11 P'D_10 D11 .. + also have "... = D $$ (0, 0) * (P' $$ (1, 0) * Q' $$ (0, 1) + + P' $$ (1, 1) * k * Q' $$ (1, 1))" by (simp add: distrib_left) + finally have u_dvd_c: "u dvd c" unfolding u_def D_def dvd_def by auto + show "\x\{a,b,c}. u dvd x" using u_dvd_a u_dvd_b u_dvd_c by auto + qed (simp) + have "ideal_generated {p*a,p*b+q*c} = ideal_generated {1}" + by (metis (no_types, lifting) eq add.assoc ideal_generated_1 ideal_generated_pair_UNIV + mult.commute semiring_normalization_rules(34) u_dvd_1) + from this show "\p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1}" + by auto +qed + +lemma necessity: + assumes "(\(A::'a mat). admits_diagonal_reduction A)" + shows "(\(A::'a mat). admits_triangular_reduction A)" + and "\a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} + \ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})" + using necessity_D' admits_diagonal_imp_admits_triangular assms + by blast+ + +text \In the article, the authors change the notation and assume $(a,b,c) = (1)$. However, +we have to provide here the complete prove. To to this, I obtained a $D$ matrix such that +$A' = A*D$ and $D$ is a diagonal matrix with $d$ in the diagonal. Proving that $D$ is +left and right commutative, I can follow the reasoning in the article\ + +lemma sufficiency: + assumes hermite_ring: "(\(A::'a mat). admits_triangular_reduction A)" + and D': "\a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} + \ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})" + shows "(\(A::'a mat). admits_diagonal_reduction A)" +proof - + have admits_1x2: "\(A::'a mat) \ carrier_mat 1 2. admits_diagonal_reduction A" + using hermite_ring triangular_eq_diagonal_1x2 by blast + have admits_2x2: "\(A::'a mat) \ carrier_mat 2 2. admits_diagonal_reduction A" + proof + fix B::"'a mat" assume B: "B \ carrier_mat 2 2" + obtain U where BU: "lower_triangular (B*U)" and inv_U: "invertible_mat U" + and U: "U \ carrier_mat 2 2" + using hermite_ring unfolding admits_triangular_reduction_def using B by fastforce + define A where "A = B*U" + define a where "a = A $$ (0,0)" + define b where "b = A $$ (1,0)" + define c where "c = A $$ (1,1)" + have A: "A \ carrier_mat 2 2" using U B A_def by auto + have A_01: "A$$(0,1) = 0" using BU U B unfolding lower_triangular_def A_def by auto + obtain d::'a where i: "ideal_generated {a,b,c} = ideal_generated {d}" + (*This fact is true since all the finitely generated ideals are principal ideals + in a Hermite ring*) + proof - + have "OFCLASS('a, bezout_ring_class)" by (rule Hermite_ring_imp_Bezout_ring, + insert OFCLASS_Hermite_ring_def[where ?'a='a] hermite_ring, auto) + hence "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus" + using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a = 'a] by auto + hence "(\I::'a::comm_ring_1 set. finitely_generated_ideal I \ principal_ideal I)" + using bezout_ring_iff_fin_gen_principal_ideal2 by auto + moreover have "finitely_generated_ideal (ideal_generated {a,b,c})" + unfolding finitely_generated_ideal_def + using ideal_ideal_generated by force + ultimately have "principal_ideal (ideal_generated {a,b,c})" by auto + thus ?thesis using that unfolding principal_ideal_def by auto + qed + have d_dvd_a: "d dvd a" and d_dvd_b: "d dvd b" and d_dvd_c: "d dvd c" + using i ideal_generated_singleton_dvd by blast+ + obtain a1 b1 c1 where a1: "a = a1 * d" and b1: "b = b1 * d" and c1: "c = c1 * d" + and i2: "ideal_generated {a1,b1,c1} = ideal_generated {1}" + proof - + have T: "\a b. \a1 b1 d. a = a1 * d \ b = b1 * d + \ ideal_generated {a1, b1} = ideal_generated {1::'a}" + by (rule theorem3_part2[OF hermite_ring]) (*Hermite ring is equivalent to the property T*) + from this obtain a1' b1' d' where 1: "a = a1' * d'" and 2: "b = b1' * d'" + and 3: "ideal_generated {a1', b1'} = ideal_generated {1::'a}" by blast + have "\a1 b1 c1. a = a1 * d \ b = b1 * d \ c = c1 * d + \ ideal_generated {a1, b1, c1} = ideal_generated {1}" + by (rule corollary5[OF T i]) + from this show ?thesis using that by auto + qed + + define D where "D = d \\<^sub>m (1\<^sub>m 2)" + define A' where "A' = Matrix.mat 2 2 (\(i,j). if i = 0 \ j = 0 then a1 else + if i = 1 \ j = 0 then b1 else + if i = 0 \ j = 1 then 0 else c1)" + have D: "D \ carrier_mat 2 2" and A': "A'\ carrier_mat 2 2" unfolding A'_def D_def by auto + have A_A'D: "A = A' * D" + by (rule eq_matI, insert D A' A a1 b1 c1 A_01 sum_two_rw a_def b_def c_def, + unfold scalar_prod_def Matrix.row_def col_def D_def A'_def, + auto simp add: sum_two_rw less_Suc_eq numerals(2)) + have "1\ ideal_generated{a1,b1,c1}" using i2 by (simp add: ideal_generated_in) + from this obtain f where d: "(\i\{a1,b1,c1}. f i * i) = 1" + using ideal_explicit2[of "{a1,b1,c1}"] by auto + from this obtain x y z where "x*a1+y*b1+z*c1 = 1" + using sum_three_elements[of _ a1 b1 c1] by metis + hence xa1_yb1_zc1_dvd_1: "x * a1 + y * b1 + z * c1 dvd 1" by auto + obtain p q where i3: "ideal_generated {p*a1,p*b1+q*c1} = ideal_generated {1}" + using D' i2 by blast + have "ideal_generated {p,q} = UNIV" + proof - + obtain X Y where e: "X*p*a1 + Y*(p*b1+q*c1) = 1" + by (metis i3 ideal_generated_1 ideal_generated_pair_exists_UNIV mult.assoc) + have "X*p*a1 + Y*(p*b1+q*c1) = X*p*a1 + Y*p*b1+Y*q*c1" + by (simp add: add.assoc mult.assoc semiring_normalization_rules(34)) + also have "... = (X*a1+Y*b1) * p + (Y * c1) * q" + by (simp add: mult.commute ring_class.ring_distribs) + finally have "(X*a1+Y*b1) * p + Y * c1 * q = 1" using e by simp + from this show ?thesis by (rule ideal_generated_pair_UNIV, simp) + qed + from this obtain u v where pu_qv_1: "p*u - q * v = 1" + by (metis Groups.mult_ac(2) diff_minus_eq_add ideal_generated_1 + ideal_generated_pair_exists_UNIV mult_minus_left) + let ?P = "Matrix.mat 2 2 (\(i,j). if i = 0 \ j = 0 then p else + if i = 1 \ j = 0 then q else + if i = 0 \ j = 1 then v else u)" + have P: "?P \ carrier_mat 2 2" by auto + have "Determinant.det ?P = 1" using pu_qv_1 unfolding det_2[OF P] by (simp add: mult.commute) + hence inv_P: "invertible_mat ?P" + by (metis (no_types, lifting) P dvd_refl invertible_iff_is_unit_JNF) + define S1 where "S1 = A'*?P" + have S1: "S1 \ carrier_mat 2 2" using A' P S1_def mult_carrier_mat by blast + have S1_00: "S1 $$(0,0) = p*a1" and S1_01: "S1 $$(1,0) = p*b1+q*c1" + unfolding S1_def times_mat_def scalar_prod_def using A' P BU U B + unfolding A'_def upper_triangular_def + by (auto, unfold sum_two_rw, auto simp add: A'_def a_def b_def c_def) + obtain q00 and q01 where q00_q01: "p*a1*q00 + (p*b1+q*c1)*q01 = 1" using i3 + by (metis ideal_generated_1 ideal_generated_pair_exists_pq1 mult.commute) + define q10 where "q10 = - (p*b1+q*c1)" + define q11 where "q11 = p*a1" + have q10_q11: "p*a1*q10 + (p*b1+q*c1)*q11 = 0" unfolding q10_def q11_def + by (auto simp add: Rings.ring_distribs(1) Rings.ring_distribs(4) semiring_normalization_rules(7)) + let ?Q = "Matrix.mat 2 2 (\(i,j). if i = 0 \ j = 0 then q00 else + if i = 1 \ j = 0 then q10 else + if i = 0 \ j = 1 then q01 else q11)" + have Q: "?Q \ carrier_mat 2 2" by auto + have "Determinant.det ?Q = 1" using q00_q01 unfolding det_2[OF Q] unfolding q10_def q11_def + by (auto, metis (no_types, lifting) add_uminus_conv_diff diff_minus_eq_add more_arith_simps(7) + more_arith_simps(9) mult.commute) + hence inv_Q: "invertible_mat ?Q" by (smt Q dvd_refl invertible_iff_is_unit_JNF) + define S2 where "S2 = ?Q * S1 " + have S2: "S2 \ carrier_mat 2 2" using A' P S2_def S1 Q mult_carrier_mat by blast + have S2_00: "S2 $$ (0,0) = 1" unfolding mat_mult2_00[OF Q S1 S2_def] using q00_q01 + unfolding S1_00 S1_01 by (simp add: mult.commute) + have S2_10: "S2 $$ (1,0) = 0" unfolding mat_mult2_10[OF Q S1 S2_def] + using q10_q11 unfolding S1_00 S1_01 by (simp add: Groups.mult_ac(2)) + (*Now we have a zero in the upper-right position. + We want to get also a zero in the lower-left position.*) + let ?P1 ="(addrow_mat 2 (- (S2$$(0,1))) 0 1)" + have P1: "?P1 \ carrier_mat 2 2" by auto + have inv_P1: "invertible_mat ?P1" + by (metis addrow_mat_carrier arithmetic_simps(78) det_addrow_mat dvd_def + invertible_iff_is_unit_JNF numeral_One zero_neq_numeral) + define S3 where "S3 = S2 * ?P1" + have P1_P_A': " A' *?P *?P1 \ carrier_mat 2 2" using P1 P A' mult_carrier_mat by auto + have S3: "S3 \ carrier_mat 2 2" using P1 S2 S3_def mult_carrier_mat by blast + have S3_00: "S3 $$ (0,0) = 1" using S2_00 unfolding mat_mult2_00[OF S2 P1 S3_def] by auto + moreover have S3_01: "S3 $$ (0,1) = 0" using S2_00 unfolding mat_mult2_01[OF S2 P1 S3_def] by auto + moreover have S3_10: "S3 $$ (1,0) = 0" using S2_10 unfolding mat_mult2_10[OF S2 P1 S3_def] by auto + ultimately have SNF_S3: "Smith_normal_form_mat S3" + using S3 unfolding Smith_normal_form_mat_def isDiagonal_mat_def + using less_2_cases by auto + hence SNF_S3_D: "Smith_normal_form_mat (S3*D)" + using D_def S3 SNF_preserved_multiples_identity by blast + have "S3 * D = ?Q * A' * ?P * ?P1 * D" using S1_def S2_def S3_def + by (smt A' P Q S1 addrow_mat_carrier assoc_mult_mat) + also have "... = ?Q * A' * ?P * (?P1 * D)" + by (meson A' D addrow_mat_carrier assoc_mult_mat mat_carrier mult_carrier_mat) + also have "... = ?Q * A' * ?P * (D * ?P1)" + using commute_multiples_identity[OF P1] unfolding D_def by auto + also have "... = ?Q * A' * (?P * (D * ?P1))" + by (smt A' D assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def) + also have "... = ?Q * A' * (D * (?P * ?P1))" + by (smt D D_def P P1 assoc_mult_mat commute_multiples_identity) + also have "... = ?Q * (A' * D) * (?P * ?P1)" + by (smt A' D assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def) + also have "... = ?Q * A * (?P * ?P1)" unfolding A_A'D by auto + also have "... = ?Q * B * (U * (?P * ?P1))" unfolding A_def + by (smt B U assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def) + finally have S3_D_rw: "S3 * D = ?Q * B * (U * (?P * ?P1))" . + show "admits_diagonal_reduction B" + proof (rule admits_diagonal_reduction_intro[OF _ _ inv_Q]) + show "(U* (?P * ?P1)) \ carrier_mat (dim_col B) (dim_col B)" using B U by auto + show "?Q \ carrier_mat (dim_row B) (dim_row B)" using Q B by auto + show "invertible_mat (U * (?P * ?P1))" + by (metis (no_types, lifting) P1 U carrier_matD(1) carrier_matD(2) inv_P inv_P1 inv_U + invertible_mult_JNF mat_carrier times_mat_def) + show "Smith_normal_form_mat (?Q * B *(U* (?P * ?P1)))" using SNF_S3_D S3_D_rw by simp + qed + qed + obtain Smith_1x2 where Smith_1x2: "\(A::'a mat)\carrier_mat 1 2. is_SNF A (Smith_1x2 A)" + using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all[OF admits_1x2] by auto + from this obtain Smith_1x2' + where Smith_1x2': "\(A::'a mat)\carrier_mat 1 2. is_SNF A (1\<^sub>m 1, Smith_1x2' A)" + using Smith_1xn_two_matrices_all[OF Smith_1x2] by auto + obtain Smith_2x2 where Smith_2x2: "\(A::'a mat)\carrier_mat 2 2. is_SNF A (Smith_2x2 A)" + using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all[OF admits_2x2] by auto + have d: "is_div_op (\a b. (SOME k. k * b = a))" using div_op_SOME by auto + interpret Smith_Impl Smith_1x2' Smith_2x2 "(\a b. (SOME k. k * b = a))" + using Smith_1x2' Smith_2x2 d by (unfold_locales, auto) + show ?thesis using is_SNF_Smith_mxn + by (meson admits_diagonal_reduction_eq_exists_algorithm_is_SNF carrier_mat_triv) +qed + +subsection \Final theorem\ + +(* Characterization of elementary divisor rings (theorem 6)*) + +theorem edr_characterization: + "(\(A::'a mat). admits_diagonal_reduction A) = ((\(A::'a mat). admits_triangular_reduction A) + \ (\a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} + \ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" + using necessity sufficiency by blast + + +corollary OFCLASS_edr_characterization: +"OFCLASS('a, elementary_divisor_ring_class) \ (OFCLASS('a, Hermite_ring_class) + &&& (\a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} + \ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" (is "?lhs \ ?rhs") +proof + assume 1: "OFCLASS('a, elementary_divisor_ring_class)" + hence admits_diagonal: "\A::'a mat. admits_diagonal_reduction A" + using conjunctionD2[OF 1[unfolded elementary_divisor_ring_class_def]] + unfolding class.elementary_divisor_ring_def by auto + have "\A::'a mat. admits_triangular_reduction A" by (simp add: admits_diagonal necessity(1)) + hence OFCLASS_Hermite: "OFCLASS('a, Hermite_ring_class)" by (intro_classes, simp) + moreover have "\a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} + \ (\p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})" + using admits_diagonal necessity(2) by blast + ultimately show "OFCLASS('a, Hermite_ring_class) &&& + \a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} + \ (\p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})" + by auto +next + assume 1: "OFCLASS('a, Hermite_ring_class) &&& + \a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} \ + (\p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})" + have H: "OFCLASS('a, Hermite_ring_class)" + and 2: "\a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} \ + (\p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})" + using conjunctionD1[OF 1] conjunctionD2[OF 1] by auto + have "\A::'a mat. admits_triangular_reduction A" + using H unfolding OFCLASS_Hermite_ring_def by auto + hence a: "\A::'a mat. admits_diagonal_reduction A" using 2 sufficiency by blast + show "OFCLASS('a, elementary_divisor_ring_class)" by (intro_classes, simp add: a) +qed + +corollary edr_characterization_class: +"class.elementary_divisor_ring TYPE('a) + = (class.Hermite_ring TYPE('a) + \ (\a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} +\ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" (is "?lhs = (?H \ ?D')") +proof + assume 1: ?lhs + hence admits_diagonal: "\A::'a mat. admits_diagonal_reduction A" + unfolding class.elementary_divisor_ring_def . + have admits_triangular: "\A::'a mat. admits_triangular_reduction A" + using 1 necessity(1) unfolding class.elementary_divisor_ring_def by blast + hence "?H" unfolding class.Hermite_ring_def by auto + moreover have "?D'" using admits_diagonal necessity(2) by blast + ultimately show "(?H \ ?D')" by simp +next + assume HD': "(?H \ ?D')" + hence admits_triangular: "\A::'a mat. admits_triangular_reduction A" + unfolding class.Hermite_ring_def by auto + hence admits_diagonal: "\A::'a mat. admits_diagonal_reduction A" + using edr_characterization HD' by auto + thus ?lhs unfolding class.elementary_divisor_ring_def by auto +qed + + +corollary edr_iff_T_D': + shows "class.elementary_divisor_ring TYPE('a) = ( + (\a b::'a. \ a1 b1 d. a = a1*d \ b = b1*d \ ideal_generated {a1,b1} = ideal_generated {1}) + \ (\a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} + \ (\p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})) + )" (is "?lhs = (?T \ ?D')") +proof + assume 1: ?lhs + hence "\A::'a mat. admits_triangular_reduction A" + unfolding class.elementary_divisor_ring_def using necessity(1) by blast + hence "?T" using theorem3_part2 by simp + moreover have "?D'" using 1 unfolding edr_characterization_class by auto + ultimately show "(?T \ ?D')" by simp +next + assume TD': "(?T \ ?D')" + hence "class.Hermite_ring TYPE('a)" + unfolding class.Hermite_ring_def using theorem3_part1 TD' by auto + thus ?lhs using edr_characterization_class TD' by auto +qed + +end +end diff --git a/thys/Smith_Normal_Form/Finite_Field_Mod_Type_Connection.thy b/thys/Smith_Normal_Form/Finite_Field_Mod_Type_Connection.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Finite_Field_Mod_Type_Connection.thy @@ -0,0 +1,77 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Connection between @{text "mod_ring"} and @{text "mod_type"}\ + +text \This file shows that the type @{text "mod_ring"}, which is defined in the + Berlekamp--Zassenhaus development, is an instantiation of the type class @{text "mod_type"}.\ + +theory Finite_Field_Mod_Type_Connection + imports + Berlekamp_Zassenhaus.Finite_Field + Rank_Nullity_Theorem.Mod_Type +begin + +instantiation mod_ring :: (finite) ord +begin +definition less_eq_mod_ring :: "'a mod_ring \ 'a mod_ring \ bool" + where "less_eq_mod_ring x y = (to_int_mod_ring x \ to_int_mod_ring y)" + +definition less_mod_ring :: "'a mod_ring \ 'a mod_ring \ bool" + where "less_mod_ring x y = (to_int_mod_ring x < to_int_mod_ring y)" + +instance proof qed +end + +instantiation mod_ring :: (finite) linorder +begin +instance by (intro_classes, unfold less_eq_mod_ring_def less_mod_ring_def) (transfer, auto) +end + + +instance mod_ring :: (finite) wellorder +proof - +have "wf {(x :: 'a mod_ring, y). x < y}" + by (auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI) + thus "OFCLASS('a mod_ring, wellorder_class)" + by(rule wf_wellorderI) intro_classes +qed + + +lemma strict_mono_to_int_mod_ring: "strict_mono to_int_mod_ring" + unfolding strict_mono_def unfolding less_mod_ring_def by auto + + +instantiation mod_ring :: (nontriv) mod_type +begin +definition Rep_mod_ring :: "'a mod_ring \ int" + where "Rep_mod_ring x = to_int_mod_ring x" + +definition Abs_mod_ring :: "int \ 'a mod_ring" + where "Abs_mod_ring x = of_int_mod_ring x" + +instance +proof (intro_classes) + show "type_definition (Rep::'a mod_ring \ int) Abs {0.. 'a mod_ring) 0" + by (simp add: Abs_mod_ring_def) + show "1 = (Abs::int \ 'a mod_ring) 1" + by (metis (mono_tags, hide_lams) Abs_mod_ring_def of_int_hom.hom_one of_int_of_int_mod_ring) + fix x y::"'a mod_ring" + show "x + y = Abs ((Rep x + Rep y) mod int CARD('a mod_ring))" + unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto) + show "- x = Abs (- Rep x mod int CARD('a mod_ring))" + unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto simp add: zmod_zminus1_eq_if) + show "x * y = Abs (Rep x * Rep y mod int CARD('a mod_ring))" + unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto) + show "x - y = Abs ((Rep x - Rep y) mod int CARD('a mod_ring))" + unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto) + show "strict_mono (Rep::'a mod_ring \ int)" unfolding Rep_mod_ring_def + by (rule strict_mono_to_int_mod_ring) +qed +end +end diff --git a/thys/Smith_Normal_Form/Mod_Type_Connect.thy b/thys/Smith_Normal_Form/Mod_Type_Connect.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Mod_Type_Connect.thy @@ -0,0 +1,581 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \A new bridge to convert theorems from JNF to HOL Analysis and vice-versa, +based on the @{text "mod_type"} class\ + +theory Mod_Type_Connect + imports + Perron_Frobenius.HMA_Connect + Rank_Nullity_Theorem.Mod_Type + Gauss_Jordan.Elementary_Operations +begin + +text \Some lemmas on @{text "Mod_Type.to_nat"} and @{text "Mod_Type.from_nat"} are added to have +them with the same names as the analogous ones for @{text "Bij_Nat.to_nat"} +and @{text "Bij_Nat.to_nat"}.\ + +lemma inj_to_nat: "inj to_nat" by (simp add: inj_on_def) +lemmas from_nat_inj = from_nat_eq_imp_eq +lemma range_to_nat: "range (to_nat :: 'a :: mod_type \ nat) = {0 ..< CARD('a)}" + by (simp add: bij_betw_imp_surj_on mod_type_class.bij_to_nat) + + +text \This theory is an adaptation of the one presented in @{text "Perron_Frobenius.HMA_Connect"}, + but for matrices and vectors where indexes have the @{text "mod_type"} class restriction. + + It is worth noting that some definitions still use the old abbreviation for HOL Analysis + (HMA, from HOL Multivariate Analysis) instead of HA. This is done to be consistent with + the existing names in the Perron-Frobenius development\ + +context includes vec.lifting +begin +end + +definition from_hma\<^sub>v :: "'a ^ 'n :: mod_type \ 'a Matrix.vec" where + "from_hma\<^sub>v v = Matrix.vec CARD('n) (\ i. v $h from_nat i)" + +definition from_hma\<^sub>m :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type \ 'a Matrix.mat" where + "from_hma\<^sub>m a = Matrix.mat CARD('nr) CARD('nc) (\ (i,j). a $h from_nat i $h from_nat j)" + +definition to_hma\<^sub>v :: "'a Matrix.vec \ 'a ^ 'n :: mod_type" where + "to_hma\<^sub>v v = (\ i. v $v to_nat i)" + +definition to_hma\<^sub>m :: "'a Matrix.mat \ 'a ^ 'nc :: mod_type ^ 'nr :: mod_type " where + "to_hma\<^sub>m a = (\ i j. a $$ (to_nat i, to_nat j))" + +lemma to_hma_from_hma\<^sub>v[simp]: "to_hma\<^sub>v (from_hma\<^sub>v v) = v" + by (auto simp: to_hma\<^sub>v_def from_hma\<^sub>v_def to_nat_less_card) + +lemma to_hma_from_hma\<^sub>m[simp]: "to_hma\<^sub>m (from_hma\<^sub>m v) = v" + by (auto simp: to_hma\<^sub>m_def from_hma\<^sub>m_def to_nat_less_card) + +lemma from_hma_to_hma\<^sub>v[simp]: + "v \ carrier_vec (CARD('n)) \ from_hma\<^sub>v (to_hma\<^sub>v v :: 'a ^ 'n :: mod_type) = v" + by (auto simp: to_hma\<^sub>v_def from_hma\<^sub>v_def to_nat_from_nat_id) + +lemma from_hma_to_hma\<^sub>m[simp]: + "A \ carrier_mat (CARD('nr)) (CARD('nc)) \ from_hma\<^sub>m (to_hma\<^sub>m A :: 'a ^ 'nc :: mod_type ^ 'nr :: mod_type) = A" + by (auto simp: to_hma\<^sub>m_def from_hma\<^sub>m_def to_nat_from_nat_id) + +lemma from_hma\<^sub>v_inj[simp]: "from_hma\<^sub>v x = from_hma\<^sub>v y \ x = y" + by (intro iffI, insert to_hma_from_hma\<^sub>v[of x], auto) + +lemma from_hma\<^sub>m_inj[simp]: "from_hma\<^sub>m x = from_hma\<^sub>m y \ x = y" + by(intro iffI, insert to_hma_from_hma\<^sub>m[of x], auto) + +definition HMA_V :: "'a Matrix.vec \ 'a ^ 'n :: mod_type \ bool" where + "HMA_V = (\ v w. v = from_hma\<^sub>v w)" + +definition HMA_M :: "'a Matrix.mat \ 'a ^ 'nc :: mod_type ^ 'nr :: mod_type \ bool" where + "HMA_M = (\ a b. a = from_hma\<^sub>m b)" + +definition HMA_I :: "nat \ 'n :: mod_type \ bool" where + "HMA_I = (\ i a. i = to_nat a)" + + + +context includes lifting_syntax +begin + +lemma Domainp_HMA_V [transfer_domain_rule]: + "Domainp (HMA_V :: 'a Matrix.vec \ 'a ^ 'n :: mod_type \ bool) = (\ v. v \ carrier_vec (CARD('n )))" + by(intro ext iffI, insert from_hma_to_hma\<^sub>v[symmetric], auto simp: from_hma\<^sub>v_def HMA_V_def) + +lemma Domainp_HMA_M [transfer_domain_rule]: + "Domainp (HMA_M :: 'a Matrix.mat \ 'a ^ 'nc :: mod_type ^ 'nr :: mod_type \ bool) + = (\ A. A \ carrier_mat CARD('nr) CARD('nc))" + by (intro ext iffI, insert from_hma_to_hma\<^sub>m[symmetric], auto simp: from_hma\<^sub>m_def HMA_M_def) + +lemma Domainp_HMA_I [transfer_domain_rule]: + "Domainp (HMA_I :: nat \ 'n :: mod_type \ bool) = (\ i. i < CARD('n))" (is "?l = ?r") +proof (intro ext) + fix i :: nat + show "?l i = ?r i" + unfolding HMA_I_def Domainp_iff + by (auto intro: exI[of _ "from_nat i"] simp: to_nat_from_nat_id to_nat_less_card) +qed + +lemma bi_unique_HMA_V [transfer_rule]: "bi_unique HMA_V" "left_unique HMA_V" "right_unique HMA_V" + unfolding HMA_V_def bi_unique_def left_unique_def right_unique_def by auto + +lemma bi_unique_HMA_M [transfer_rule]: "bi_unique HMA_M" "left_unique HMA_M" "right_unique HMA_M" + unfolding HMA_M_def bi_unique_def left_unique_def right_unique_def by auto + +lemma bi_unique_HMA_I [transfer_rule]: "bi_unique HMA_I" "left_unique HMA_I" "right_unique HMA_I" + unfolding HMA_I_def bi_unique_def left_unique_def right_unique_def by auto + +lemma right_total_HMA_V [transfer_rule]: "right_total HMA_V" + unfolding HMA_V_def right_total_def by simp + +lemma right_total_HMA_M [transfer_rule]: "right_total HMA_M" + unfolding HMA_M_def right_total_def by simp + +lemma right_total_HMA_I [transfer_rule]: "right_total HMA_I" + unfolding HMA_I_def right_total_def by simp + +lemma HMA_V_index [transfer_rule]: "(HMA_V ===> HMA_I ===> (=)) ($v) ($h)" + unfolding rel_fun_def HMA_V_def HMA_I_def from_hma\<^sub>v_def + by (auto simp: to_nat_less_card) + + +lemma HMA_M_index [transfer_rule]: + "(HMA_M ===> HMA_I ===> HMA_I ===> (=)) (\ A i j. A $$ (i,j)) index_hma" + by (intro rel_funI, simp add: index_hma_def to_nat_less_card HMA_M_def HMA_I_def from_hma\<^sub>m_def) + + +lemma HMA_V_0 [transfer_rule]: "HMA_V (0\<^sub>v CARD('n)) (0 :: 'a :: zero ^ 'n:: mod_type)" + unfolding HMA_V_def from_hma\<^sub>v_def by auto + +lemma HMA_M_0 [transfer_rule]: + "HMA_M (0\<^sub>m CARD('nr) CARD('nc)) (0 :: 'a :: zero ^ 'nc:: mod_type ^ 'nr :: mod_type)" + unfolding HMA_M_def from_hma\<^sub>m_def by auto + +lemma HMA_M_1[transfer_rule]: + "HMA_M (1\<^sub>m (CARD('n))) (mat 1 :: 'a::{zero,one}^'n:: mod_type^'n:: mod_type)" + unfolding HMA_M_def + by (auto simp add: mat_def from_hma\<^sub>m_def from_nat_inj) + + +lemma from_hma\<^sub>v_add: "from_hma\<^sub>v v + from_hma\<^sub>v w = from_hma\<^sub>v (v + w)" + unfolding from_hma\<^sub>v_def by auto + +lemma HMA_V_add [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (+) (+) " + unfolding rel_fun_def HMA_V_def + by (auto simp: from_hma\<^sub>v_add) + +lemma from_hma\<^sub>v_diff: "from_hma\<^sub>v v - from_hma\<^sub>v w = from_hma\<^sub>v (v - w)" + unfolding from_hma\<^sub>v_def by auto + +lemma HMA_V_diff [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (-) (-)" + unfolding rel_fun_def HMA_V_def + by (auto simp: from_hma\<^sub>v_diff) + +lemma from_hma\<^sub>m_add: "from_hma\<^sub>m a + from_hma\<^sub>m b = from_hma\<^sub>m (a + b)" + unfolding from_hma\<^sub>m_def by auto + +lemma HMA_M_add [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (+) (+) " + unfolding rel_fun_def HMA_M_def + by (auto simp: from_hma\<^sub>m_add) + +lemma from_hma\<^sub>m_diff: "from_hma\<^sub>m a - from_hma\<^sub>m b = from_hma\<^sub>m (a - b)" + unfolding from_hma\<^sub>m_def by auto + +lemma HMA_M_diff [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (-) (-) " + unfolding rel_fun_def HMA_M_def + by (auto simp: from_hma\<^sub>m_diff) + +lemma scalar_product: fixes v :: "'a :: semiring_1 ^ 'n :: mod_type" + shows "scalar_prod (from_hma\<^sub>v v) (from_hma\<^sub>v w) = scalar_product v w" + unfolding scalar_product_def scalar_prod_def from_hma\<^sub>v_def dim_vec + by (simp add: sum.reindex[OF inj_to_nat, unfolded range_to_nat]) + +lemma [simp]: + "from_hma\<^sub>m (y :: 'a ^ 'nc :: mod_type ^ 'nr:: mod_type) \ carrier_mat (CARD('nr)) (CARD('nc))" + "dim_row (from_hma\<^sub>m (y :: 'a ^ 'nc:: mod_type ^ 'nr :: mod_type)) = CARD('nr)" + "dim_col (from_hma\<^sub>m (y :: 'a ^ 'nc :: mod_type ^ 'nr:: mod_type )) = CARD('nc)" + unfolding from_hma\<^sub>m_def by simp_all + +lemma [simp]: + "from_hma\<^sub>v (y :: 'a ^ 'n:: mod_type) \ carrier_vec (CARD('n))" + "dim_vec (from_hma\<^sub>v (y :: 'a ^ 'n:: mod_type)) = CARD('n)" + unfolding from_hma\<^sub>v_def by simp_all + +lemma HMA_scalar_prod [transfer_rule]: + "(HMA_V ===> HMA_V ===> (=)) scalar_prod scalar_product" + by (auto simp: HMA_V_def scalar_product) + +lemma HMA_row [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (\ i a. Matrix.row a i) row" + unfolding HMA_M_def HMA_I_def HMA_V_def + by (auto simp: from_hma\<^sub>m_def from_hma\<^sub>v_def to_nat_less_card row_def) + +lemma HMA_col [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (\ i a. col a i) column" + unfolding HMA_M_def HMA_I_def HMA_V_def + by (auto simp: from_hma\<^sub>m_def from_hma\<^sub>v_def to_nat_less_card column_def) + + +lemma HMA_M_mk_mat[transfer_rule]: "((HMA_I ===> HMA_I ===> (=)) ===> HMA_M) + (\ f. Matrix.mat (CARD('nr)) (CARD('nc)) (\ (i,j). f i j)) + (mk_mat :: (('nr \ 'nc \ 'a) \ 'a^'nc:: mod_type^'nr:: mod_type))" +proof- + { + fix x y i j + assume id: "\ (ya :: 'nr) (yb :: 'nc). (x (to_nat ya) (to_nat yb) :: 'a) = y ya yb" + and i: "i < CARD('nr)" and j: "j < CARD('nc)" + from to_nat_from_nat_id[OF i] to_nat_from_nat_id[OF j] id[rule_format, of "from_nat i" "from_nat j"] + have "x i j = y (from_nat i) (from_nat j)" by auto + } + thus ?thesis + unfolding rel_fun_def mk_mat_def HMA_M_def HMA_I_def from_hma\<^sub>m_def by auto +qed + +lemma HMA_M_mk_vec[transfer_rule]: "((HMA_I ===> (=)) ===> HMA_V) + (\ f. Matrix.vec (CARD('n)) (\ i. f i)) + (mk_vec :: (('n \ 'a) \ 'a^'n:: mod_type))" +proof- + { + fix x y i + assume id: "\ (ya :: 'n). (x (to_nat ya) :: 'a) = y ya" + and i: "i < CARD('n)" + from to_nat_from_nat_id[OF i] id[rule_format, of "from_nat i"] + have "x i = y (from_nat i)" by auto + } + thus ?thesis + unfolding rel_fun_def mk_vec_def HMA_V_def HMA_I_def from_hma\<^sub>v_def by auto +qed + + +lemma mat_mult_scalar: "A ** B = mk_mat (\ i j. scalar_product (row i A) (column j B))" + unfolding vec_eq_iff matrix_matrix_mult_def scalar_product_def mk_mat_def + by (auto simp: row_def column_def) + +lemma mult_mat_vec_scalar: "A *v v = mk_vec (\ i. scalar_product (row i A) v)" + unfolding vec_eq_iff matrix_vector_mult_def scalar_product_def mk_mat_def mk_vec_def + by (auto simp: row_def column_def) + +lemma dim_row_transfer_rule: + "HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type) \ (=) (dim_row A) (CARD('nr))" + unfolding HMA_M_def by auto + +lemma dim_col_transfer_rule: + "HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type) \ (=) (dim_col A) (CARD('nc))" + unfolding HMA_M_def by auto + + +lemma HMA_M_mult [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (*) (**)" +proof - + { + fix A B :: "'a :: semiring_1 mat" and A' :: "'a ^ 'n :: mod_type ^ 'nr:: mod_type" + and B' :: "'a ^ 'nc :: mod_type ^ 'n:: mod_type" + assume 1[transfer_rule]: "HMA_M A A'" "HMA_M B B'" + note [transfer_rule] = dim_row_transfer_rule[OF 1(1)] dim_col_transfer_rule[OF 1(2)] + have "HMA_M (A * B) (A' ** B')" + unfolding times_mat_def mat_mult_scalar + by (transfer_prover_start, transfer_step+, transfer, auto) + } + thus ?thesis by blast +qed + + +lemma HMA_V_smult [transfer_rule]: "((=) ===> HMA_V ===> HMA_V) (\\<^sub>v) (*s)" + unfolding smult_vec_def + unfolding rel_fun_def HMA_V_def from_hma\<^sub>v_def + by auto + +lemma HMA_M_mult_vec [transfer_rule]: "(HMA_M ===> HMA_V ===> HMA_V) (*\<^sub>v) (*v)" +proof - + { + fix A :: "'a :: semiring_1 mat" and v :: "'a Matrix.vec" + and A' :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type" and v' :: "'a ^ 'nc :: mod_type" + assume 1[transfer_rule]: "HMA_M A A'" "HMA_V v v'" + note [transfer_rule] = dim_row_transfer_rule + have "HMA_V (A *\<^sub>v v) (A' *v v')" + unfolding mult_mat_vec_def mult_mat_vec_scalar + by (transfer_prover_start, transfer_step+, transfer, auto) + } + thus ?thesis by blast +qed + + +lemma HMA_det [transfer_rule]: "(HMA_M ===> (=)) Determinant.det + (det :: 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type \ 'a)" +proof - + { + fix a :: "'a ^ 'n :: mod_type^ 'n:: mod_type" + let ?tn = "to_nat :: 'n :: mod_type \ nat" + let ?fn = "from_nat :: nat \ 'n" + let ?zn = "{0..< CARD('n)}" + let ?U = "UNIV :: 'n set" + let ?p1 = "{p. p permutes ?zn}" + let ?p2 = "{p. p permutes ?U}" + let ?f= "\ p i. if i \ ?U then ?fn (p (?tn i)) else i" + let ?g = "\ p i. ?fn (p (?tn i))" + have fg: "\ a b c. (if a \ ?U then b else c) = b" by auto + have "?p2 = ?f ` ?p1" + by (rule permutes_bij', auto simp: to_nat_less_card to_nat_from_nat_id) + hence id: "?p2 = ?g ` ?p1" by simp + have inj_g: "inj_on ?g ?p1" + unfolding inj_on_def + proof (intro ballI impI ext, auto) + fix p q i + assume p: "p permutes ?zn" and q: "q permutes ?zn" + and id: "(\ i. ?fn (p (?tn i))) = (\ i. ?fn (q (?tn i)))" + { + fix i + from permutes_in_image[OF p] have pi: "p (?tn i) < CARD('n)" by (simp add: to_nat_less_card) + from permutes_in_image[OF q] have qi: "q (?tn i) < CARD('n)" by (simp add: to_nat_less_card) + from fun_cong[OF id] have "?fn (p (?tn i)) = from_nat (q (?tn i))" . + from arg_cong[OF this, of ?tn] have "p (?tn i) = q (?tn i)" + by (simp add: to_nat_from_nat_id pi qi) + } note id = this + show "p i = q i" + proof (cases "i < CARD('n)") + case True + hence "?tn (?fn i) = i" by (simp add: to_nat_from_nat_id) + from id[of "?fn i", unfolded this] show ?thesis . + next + case False + thus ?thesis using p q unfolding permutes_def by simp + qed + qed + have mult_cong: "\ a b c d. a = b \ c = d \ a * c = b * d" by simp + have "sum (\ p. + signof p * (\i\?zn. a $h ?fn i $h ?fn (p i))) ?p1 + = sum (\ p. of_int (sign p) * (\i\UNIV. a $h i $h p i)) ?p2" + unfolding id sum.reindex[OF inj_g] + proof (rule sum.cong[OF refl], unfold mem_Collect_eq o_def, rule mult_cong) + fix p + assume p: "p permutes ?zn" + let ?q = "\ i. ?fn (p (?tn i))" + from id p have q: "?q permutes ?U" by auto + from p have pp: "permutation p" unfolding permutation_permutes by auto + let ?ft = "\ p i. ?fn (p (?tn i))" + have fin: "finite ?zn" by simp + have "sign p = sign ?q \ p permutes ?zn" + proof (induct rule: permutes_induct[OF fin _ _ p]) + case 1 + show ?case by (auto simp: sign_id[unfolded id_def] permutes_id[unfolded id_def]) + next + case (2 a b p) + let ?sab = "Fun.swap a b id" + let ?sfab = "Fun.swap (?fn a) (?fn b) id" + have p_sab: "permutation ?sab" by (rule permutation_swap_id) + have p_sfab: "permutation ?sfab" by (rule permutation_swap_id) + from 2(3) have IH1: "p permutes ?zn" and IH2: "sign p = sign (?ft p)" by auto + have sab_perm: "?sab permutes ?zn" using 2(1-2) by (rule permutes_swap_id) + from permutes_compose[OF IH1 this] have perm1: "?sab o p permutes ?zn" . + from IH1 have p_p1: "p \ ?p1" by simp + hence "?ft p \ ?ft ` ?p1" by (rule imageI) + from this[folded id] have "?ft p permutes ?U" by simp + hence p_ftp: "permutation (?ft p)" unfolding permutation_permutes by auto + { + fix a b + assume a: "a \ ?zn" and b: "b \ ?zn" + hence "(?fn a = ?fn b) = (a = b)" using 2(1-2) + by (auto simp add: from_nat_eq_imp_eq) + } note inj = this + from inj[OF 2(1-2)] have id2: "sign ?sfab = sign ?sab" unfolding sign_swap_id by simp + have id: "?ft (Fun.swap a b id \ p) = Fun.swap (?fn a) (?fn b) id \ ?ft p" + proof + fix c + show "?ft (Fun.swap a b id \ p) c = (Fun.swap (?fn a) (?fn b) id \ ?ft p) c" + proof (cases "p (?tn c) = a \ p (?tn c) = b") + case True + thus ?thesis by (cases, auto simp add: o_def swap_def) + next + case False + hence neq: "p (?tn c) \ a" "p (?tn c) \ b" by auto + have pc: "p (?tn c) \ ?zn" unfolding permutes_in_image[OF IH1] + by (simp add: to_nat_less_card) + from neq[folded inj[OF pc 2(1)] inj[OF pc 2(2)]] + have "?fn (p (?tn c)) \ ?fn a" "?fn (p (?tn c)) \ ?fn b" . + with neq show ?thesis by (auto simp: o_def swap_def) + qed + qed + show ?case unfolding IH2 id sign_compose[OF p_sab 2(5)] sign_compose[OF p_sfab p_ftp] id2 + by (rule conjI[OF refl perm1]) + qed + thus "signof p = of_int (sign ?q)" unfolding signof_def sign_def by auto + show "(\i = 0..i\UNIV. a $h i $h ?q i)" unfolding + range_to_nat[symmetric] prod.reindex[OF inj_to_nat] + by (rule prod.cong[OF refl], unfold o_def, simp) + qed + } + thus ?thesis unfolding HMA_M_def + by (auto simp: from_hma\<^sub>m_def Determinant.det_def det_def) +qed + +lemma HMA_mat[transfer_rule]: "((=) ===> HMA_M) (\ k. k \\<^sub>m 1\<^sub>m CARD('n)) + (Finite_Cartesian_Product.mat :: 'a::semiring_1 \ 'a^'n :: mod_type^'n :: mod_type)" + unfolding Finite_Cartesian_Product.mat_def[abs_def] rel_fun_def HMA_M_def + by (auto simp: from_hma\<^sub>m_def from_nat_inj) + + +lemma HMA_mat_minus[transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) + (\ A B. A + map_mat uminus B) ((-) :: 'a :: group_add ^'nc:: mod_type^'nr:: mod_type + \ 'a^'nc:: mod_type^'nr:: mod_type \ 'a^'nc:: mod_type^'nr:: mod_type)" + unfolding rel_fun_def HMA_M_def from_hma\<^sub>m_def by auto + +lemma HMA_transpose_matrix [transfer_rule]: + "(HMA_M ===> HMA_M) transpose_mat transpose" + unfolding transpose_mat_def transpose_def HMA_M_def from_hma\<^sub>m_def by auto + + +lemma HMA_invertible_matrix_mod_type[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type + \ _) ===> (=)) invertible_mat invertible" +proof (intro rel_funI, goal_cases) + case (1 x y) + note rel_xy[transfer_rule] = "1" + have eq_dim: "dim_col x = dim_row x" + using Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule rel_xy + by fastforce + moreover have "\A'. y ** A' = mat 1 \ A' ** y = mat 1" + if xB: "x * B = 1\<^sub>m (dim_row x)" and Bx: "B * x = 1\<^sub>m (dim_row B)" for B + proof - + let ?A' = "Mod_Type_Connect.to_hma\<^sub>m B:: 'a :: comm_ring_1 ^ 'n :: mod_type^ 'n :: mod_type" + have rel_BA[transfer_rule]: "Mod_Type_Connect.HMA_M B ?A'" + by (metis (no_types, lifting) Bx Mod_Type_Connect.HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1) + Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.from_hma_to_hma\<^sub>m index_mult_mat(3) + index_one_mat(3) rel_xy xB) + have [simp]: "dim_row B = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_BA by blast + have [simp]: "dim_row x = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast + have "y ** ?A' = mat 1" using xB by (transfer, simp) + moreover have "?A' ** y = mat 1" using Bx by (transfer, simp) + ultimately show ?thesis by blast + qed + moreover have "\B. x * B = 1\<^sub>m (dim_row x) \ B * x = 1\<^sub>m (dim_row B)" + if yA: "y ** A' = mat 1" and Ay: "A' ** y = mat 1" for A' + proof - + let ?B = "(Mod_Type_Connect.from_hma\<^sub>m A')" + have [simp]: "dim_row x = CARD('n)" using rel_xy Mod_Type_Connect.dim_row_transfer_rule by blast + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B A'" by (simp add: Mod_Type_Connect.HMA_M_def) + hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto + have "x * ?B = 1\<^sub>m (dim_row x)" using yA by (transfer', auto) + moreover have "?B * x = 1\<^sub>m (dim_row ?B)" using Ay by (transfer', auto) + ultimately show ?thesis by auto + qed + ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto +qed + + +end + + +text \Some transfer rules for relating the elementary operations are also proved.\ + +context + includes lifting_syntax +begin + +lemma HMA_swaprows[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (Mod_Type_Connect.HMA_I :: _ \'nr :: mod_type \ _ ) + ===> (Mod_Type_Connect.HMA_I :: _ \'nr :: mod_type \ _ ) + ===> Mod_Type_Connect.HMA_M) + (\A a b. swaprows a b A) interchange_rows" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_rows_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def + to_nat_less_card to_nat_from_nat_id) + +lemma HMA_swapcols[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (Mod_Type_Connect.HMA_I :: _ \'nc :: mod_type \ _ ) + ===> (Mod_Type_Connect.HMA_I :: _ \'nc :: mod_type \ _ ) + ===> Mod_Type_Connect.HMA_M) + (\A a b. swapcols a b A) interchange_columns" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_columns_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def + to_nat_less_card to_nat_from_nat_id) + +lemma HMA_addrow[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (Mod_Type_Connect.HMA_I :: _ \'nr :: mod_type \ _ ) + ===> (Mod_Type_Connect.HMA_I :: _ \'nr :: mod_type \ _ ) + ===> (=) + ===> Mod_Type_Connect.HMA_M) + (\A a b q. addrow q a b A) row_add" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def row_add_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def + to_nat_less_card to_nat_from_nat_id) + +lemma HMA_addcol[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (Mod_Type_Connect.HMA_I :: _ \'nc :: mod_type \ _ ) + ===> (Mod_Type_Connect.HMA_I :: _ \'nc :: mod_type \ _ ) + ===> (=) + ===> Mod_Type_Connect.HMA_M) + (\A a b q. addcol q a b A) column_add" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def column_add_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def + to_nat_less_card to_nat_from_nat_id) + +lemma HMA_multrow[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (Mod_Type_Connect.HMA_I :: _ \'nr :: mod_type \ _ ) + ===> (=) + ===> Mod_Type_Connect.HMA_M) + (\A i q. multrow i q A) mult_row" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_row_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def + to_nat_less_card to_nat_from_nat_id) + +lemma HMA_multcol[transfer_rule]: + "((Mod_Type_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \ _) + ===> (Mod_Type_Connect.HMA_I :: _ \'nc :: mod_type \ _ ) + ===> (=) + ===> Mod_Type_Connect.HMA_M) + (\A i q. multcol i q A) mult_column" + by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_column_def) + (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def + to_nat_less_card to_nat_from_nat_id) + +end + +fun HMA_M3 where + "HMA_M3 (P,A,Q) + (P' :: 'a :: comm_ring_1 ^ 'nr :: mod_type ^ 'nr :: mod_type, + A' :: 'a ^ 'nc :: mod_type ^ 'nr :: mod_type, + Q' :: 'a ^ 'nc :: mod_type ^ 'nc :: mod_type) = + (Mod_Type_Connect.HMA_M P P' \ Mod_Type_Connect.HMA_M A A' \ Mod_Type_Connect.HMA_M Q Q')" + +lemma HMA_M3_def: + "HMA_M3 A B = (Mod_Type_Connect.HMA_M (fst A) (fst B) + \ Mod_Type_Connect.HMA_M (fst (snd A)) (fst (snd B)) + \ Mod_Type_Connect.HMA_M (snd (snd A)) (snd (snd B)))" + by (smt HMA_M3.simps prod.collapse) + + +context + includes lifting_syntax +begin + +lemma Domainp_HMA_M3 [transfer_domain_rule]: + "Domainp (HMA_M3 :: _\(_\('a::comm_ring_1^'nc::mod_type^'nr::mod_type)\_)\_) + = (\(P,A,Q). P \ carrier_mat CARD('nr) CARD('nr) \ A \ carrier_mat CARD('nr) CARD('nc) + \ Q \ carrier_mat CARD('nc) CARD('nc))" +proof - + let ?HMA_M3 = "HMA_M3::_\(_\('a::comm_ring_1^'nc::mod_type^'nr::mod_type)\_)\_" + have 1: "P \ carrier_mat CARD('nr) CARD('nr) \ + A \ carrier_mat CARD('nr) CARD('nc) \ Q \ carrier_mat CARD('nc) CARD('nc)" + if "Domainp ?HMA_M3 (P,A,Q)" for P A Q + using that unfolding Domainp_iff by (auto simp add: Mod_Type_Connect.HMA_M_def) + have 2: "Domainp ?HMA_M3 (P,A,Q)" if PAQ: "P \ carrier_mat CARD('nr) CARD('nr) + \ A \ carrier_mat CARD('nr) CARD('nc) \Q \ carrier_mat CARD('nc) CARD('nc)" for P A Q + proof - + let ?P = "Mod_Type_Connect.to_hma\<^sub>m P::'a^'nr::mod_type^'nr::mod_type" + let ?A = "Mod_Type_Connect.to_hma\<^sub>m A::'a^'nc::mod_type^'nr::mod_type" + let ?Q = "Mod_Type_Connect.to_hma\<^sub>m Q::'a^'nc::mod_type^'nc::mod_type" + have "HMA_M3 (P,A,Q) (?P,?A,?Q)" + by (auto simp add: Mod_Type_Connect.HMA_M_def PAQ) + thus ?thesis unfolding Domainp_iff by auto + qed + have "fst x \ carrier_mat CARD('nr) CARD('nr) \ fst (snd x) \ carrier_mat CARD('nr) CARD('nc) + \ (snd (snd x)) \ carrier_mat CARD('nc) CARD('nc)" + if "Domainp ?HMA_M3 x" for x using 1 + by (metis (full_types) surjective_pairing that) + moreover have "Domainp ?HMA_M3 x" + if "fst x \ carrier_mat CARD('nr) CARD('nr) \ fst (snd x) \ carrier_mat CARD('nr) CARD('nc) + \ (snd (snd x)) \ carrier_mat CARD('nc) CARD('nc)" for x + using 2 + by (metis (full_types) surjective_pairing that) + ultimately show ?thesis by (intro ext iffI, unfold split_beta, metis+) +qed + +lemma bi_unique_HMA_M3 [transfer_rule]: "bi_unique HMA_M3" "left_unique HMA_M3" "right_unique HMA_M3" + unfolding HMA_M3_def bi_unique_def left_unique_def right_unique_def + by (auto simp add: Mod_Type_Connect.HMA_M_def) + +lemma right_total_HMA_M3 [transfer_rule]: "right_total HMA_M3" + unfolding HMA_M_def right_total_def + by (simp add: Mod_Type_Connect.HMA_M_def) + +end + +(* + TODO: add more theorems to connect everything from HA to JNF in this setting. +*) +end diff --git a/thys/Smith_Normal_Form/ROOT b/thys/Smith_Normal_Form/ROOT new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/ROOT @@ -0,0 +1,19 @@ +chapter AFP +session Smith_Normal_Form (AFP) = Hermite + + options [timeout = 600] + sessions + "HOL-Types_To_Sets" + Perron_Frobenius + "List-Index" + Berlekamp_Zassenhaus + theories + Diagonal_To_Smith + SNF_Uniqueness + Cauchy_Binet_HOL_Analysis + SNF_Algorithm_Two_Steps + SNF_Algorithm_Two_Steps_JNF + SNF_Algorithm_HOL_Analysis + SNF_Algorithm_Euclidean_Domain + Smith_Certified + document_files + "root.tex" diff --git a/thys/Smith_Normal_Form/Rings2_Extended.thy b/thys/Smith_Normal_Form/Rings2_Extended.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Rings2_Extended.thy @@ -0,0 +1,809 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Some theorems about rings and ideals\ + +theory Rings2_Extended + imports + Echelon_Form.Rings2 + "HOL-Types_To_Sets.Types_To_Sets" +begin + +subsection \Missing properties on ideals\ + +lemma ideal_generated_subset2: + assumes "\b\B. b \ ideal_generated A" + shows "ideal_generated B \ ideal_generated A" + by (metis (mono_tags, lifting) InterE assms ideal_generated_def +ideal_ideal_generated mem_Collect_eq subsetI) + +context comm_ring_1 +begin + +lemma ideal_explicit: "ideal_generated S + = {y. \f U. finite U \ U \ S \ (\i\U. f i * i) = y}" + by (simp add: ideal_generated_eq_left_ideal left_ideal_explicit) +end + +lemma ideal_generated_minus: + assumes a: "a \ ideal_generated (S-{a})" + shows "ideal_generated S = ideal_generated (S-{a})" +proof (cases "a \ S") + case True note a_in_S = True + show ?thesis + proof + show "ideal_generated S \ ideal_generated (S - {a})" + proof (rule ideal_generated_subset2, auto) + fix b assume b: "b \ S" show "b \ ideal_generated (S - {a})" + proof (cases "b = a") + case True + then show ?thesis using a by auto + next + case False + then show ?thesis using b + by (simp add: ideal_generated_in) + qed + qed + show "ideal_generated (S - {a}) \ ideal_generated S" + by (rule ideal_generated_subset, auto) + qed +next + case False + then show ?thesis by simp +qed + +lemma ideal_generated_dvd_eq: + assumes a_dvd_b: "a dvd b" + and a: "a \ S" + and a_not_b: "a \ b" + shows "ideal_generated S = ideal_generated (S - {b})" +proof + show "ideal_generated S \ ideal_generated (S - {b})" + proof (rule ideal_generated_subset2, auto) + fix x assume x: "x \ S" + show "x \ ideal_generated (S - {b})" + proof (cases "x = b") + case True + obtain k where b_ak: "b = a * k" using a_dvd_b unfolding dvd_def by blast + let ?f = "\c. k" + have "(\i\{a}. i * ?f i) = x" using True b_ak by auto + moreover have "{a} \ S - {b}" using a_not_b a by auto + moreover have "finite {a}" by auto + ultimately show ?thesis + unfolding ideal_def + by (metis True b_ak ideal_def ideal_generated_in ideal_ideal_generated insert_subset right_ideal_def) + next + case False + then show ?thesis by (simp add: ideal_generated_in x) + qed + qed + show "ideal_generated (S - {b}) \ ideal_generated S" by (rule ideal_generated_subset, auto) +qed + +lemma ideal_generated_dvd_eq_diff_set: + assumes i_in_I: "i\I" and i_in_J: "i \ J" and i_dvd_j: "\j\J. i dvd j" + and f: "finite J" + shows "ideal_generated I = ideal_generated (I - J)" + using f i_in_J i_dvd_j i_in_I + proof (induct J arbitrary: I) + case empty + then show ?case by auto + next + case (insert x J) + have "ideal_generated I = ideal_generated (I-{x})" + by (rule ideal_generated_dvd_eq[of i], insert insert.prems , auto) + also have "... = ideal_generated ((I-{x}) - J)" + by (rule insert.hyps, insert insert.prems insert.hyps, auto) + also have "... = ideal_generated (I - insert x J)" + using Diff_insert2[of I x J] by auto + finally show ?case . + qed + + +context comm_ring_1 +begin + +lemma ideal_generated_singleton_subset: + assumes d: "d \ ideal_generated S" and fin_S: "finite S" + shows "ideal_generated {d} \ ideal_generated S" +proof + fix x assume x: "x \ ideal_generated {d}" + obtain k where x_kd: "x = k*d " using x using obtain_sum_ideal_generated[OF x] + by (metis finite.emptyI finite.insertI sum_singleton) + show "x \ ideal_generated S" + using d ideal_eq_right_ideal ideal_ideal_generated right_ideal_def mult_commute x_kd by auto +qed + +lemma ideal_generated_singleton_dvd: + assumes i: "ideal_generated S = ideal_generated {d}" and x: "x \ S" + shows "d dvd x" + by (metis i x finite.intros dvd_ideal_generated_singleton + ideal_generated_in ideal_generated_singleton_subset) + +lemma ideal_generated_UNIV_insert: + assumes "ideal_generated S = UNIV" + shows "ideal_generated (insert a S) = UNIV" using assms + using local.ideal_generated_subset by blast + +lemma ideal_generated_UNIV_union: + assumes "ideal_generated S = UNIV" + shows "ideal_generated (A \ S) = UNIV" + using assms local.ideal_generated_subset + by (metis UNIV_I Un_subset_iff equalityI subsetI) + +lemma ideal_explicit2: + assumes "finite S" + shows "ideal_generated S = {y. \f. (\i\S. f i * i) = y}" + by (smt Collect_cong assms ideal_explicit obtain_sum_ideal_generated mem_Collect_eq subsetI) + +lemma ideal_generated_unit: + assumes u: "u dvd 1" + shows "ideal_generated {u} = UNIV" +proof - + have "x \ ideal_generated {u}" for x + proof - + obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def + using local.mult_ac(2) by blast + have "x = x * inv_u * u" using inv_u by (simp add: local.mult_ac(1)) + also have "... \ {k * u |k. k \ UNIV}" by auto + also have "... = ideal_generated {u}" unfolding ideal_generated_singleton by simp + finally show ?thesis . + qed + thus ?thesis by auto +qed + + +lemma ideal_generated_dvd_subset: + assumes x: "\x \ S. d dvd x" and S: "finite S" + shows "ideal_generated S \ ideal_generated {d}" +proof + fix x assume "x\ ideal_generated S" + from this obtain f where f: "(\i\S. f i * i) = x" using ideal_explicit2[OF S] by auto + have "d dvd (\i\S. f i * i)" by (rule dvd_sum, insert x, auto) + thus "x \ ideal_generated {d}" + using f dvd_ideal_generated_singleton' ideal_generated_in singletonI by blast +qed + + +lemma ideal_generated_mult_unit: + assumes f: "finite S" and u: "u dvd 1" + shows "ideal_generated ((\x. u*x)` S) = ideal_generated S" + using f +proof (induct S) + case empty + then show ?case by auto +next + case (insert x S) + obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def + using mult_ac by blast + have f: "finite (insert (u*x) ((\x. u*x)` S))" using insert.hyps by auto + have f2: "finite (insert x S)" by (simp add: insert(1)) + have f3: "finite S" by (simp add: insert) + have f4: "finite ((*) u ` S)" by (simp add: insert) + have inj_ux: "inj_on (\x. u*x) S" unfolding inj_on_def + by (auto, metis inv_u local.mult_1_left local.semiring_normalization_rules(18)) + have "ideal_generated ((\x. u*x)` (insert x S)) = ideal_generated (insert (u*x) ((\x. u*x)` S))" + by auto + also have "... = {y. \f. (\i\insert (u*x) ((\x. u*x)` S). f i * i) = y}" + using ideal_explicit2[OF f] by auto + also have "... = {y. \f. (\i\(insert x S). f i * i) = y}" (is "?L = ?R") + proof - + have "a \ ?L" if a: "a \ ?R" for a + proof - + obtain f where sum_rw: "(\i\(insert x S). f i * i) = a" using a by auto + define b where "b=(\i\S. f i * i)" + have "b \ ideal_generated S" unfolding b_def ideal_explicit2[OF f3] by auto + hence "b \ ideal_generated ((*) u ` S)" using insert.hyps(3) by auto + from this obtain g where "(\i\((*) u ` S). g i * i) = b" + unfolding ideal_explicit2[OF f4] by auto + hence sum_rw2: "(\i\S. f i * i) = (\i\((*) u ` S). g i * i)" unfolding b_def by auto + let ?g = "\i. if i = u*x then f x * inv_u else g i" + have sum_rw3: "sum ((\i. g i * i) \ (\x. u*x)) S = sum ((\i. ?g i * i) \ (\x. u*x)) S" + by (rule sum.cong, auto, metis inv_u local.insert(2) local.mult_1_right + local.mult_ac(2) local.semiring_normalization_rules(18)) + have sum_rw4: "(\i\(\x. u*x)` S. g i * i) = sum ((\i. g i * i) \ (\x. u*x)) S" + by (rule sum.reindex[OF inj_ux]) + have "a = f x * x + (\i\S. f i * i)" + using sum_rw local.insert(1) local.insert(2) by auto + also have "... = f x * x + (\i\(\x. u*x)` S. g i * i)" using sum_rw2 by auto + also have "... = ?g (u * x) * (u * x) + (\i\(\x. u*x)` S. g i * i)" + using inv_u by (smt local.mult_1_right local.mult_ac(1)) + also have "... = ?g (u * x) * (u * x) + sum ((\i. g i * i) \ (\x. u*x)) S" + using sum_rw4 by auto + also have "... = ((\i. ?g i * i) \ (\x. u*x)) x + sum ((\i. g i * i) \ (\x. u*x)) S" by auto + also have "... = ((\i. ?g i * i) \ (\x. u*x)) x + sum ((\i. ?g i * i) \ (\x. u*x)) S" + using sum_rw3 by auto + also have "... = sum ((\i. ?g i * i) \ (\x. u*x)) (insert x S)" + by (rule sum.insert[symmetric], auto simp add: insert) + also have "... = (\i\insert (u * x) ((\x. u*x)` S). ?g i * i)" + by (smt abel_semigroup.commute f2 image_insert inv_u mult.abel_semigroup_axioms mult_1_right + semiring_normalization_rules(18) sum.reindex_nontrivial) + also have "... = (\i\(\x. u*x)` (insert x S). ?g i * i)" by auto + finally show ?thesis by auto + qed + moreover have "a \ ?R" if a: "a \ ?L" for a + proof - + obtain f where sum_rw: "(\i\(insert (u * x) ((*) u ` S)). f i * i) = a" using a by auto + have ux_notin: "u*x \ ((*) u ` S)" + by (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI inv_u local.insert(2) local.mult_1_left + local.semiring_normalization_rules(18) subsetI) + let ?f = "(\x. f x * x)" + have "sum ?f ((*) u ` S) \ ideal_generated ((*) u ` S)" + unfolding ideal_explicit2[OF f4] by auto + from this obtain g where sum_rw1: "sum (\i. g i * i) S = sum ?f (((*) u ` S))" + using insert.hyps(3) unfolding ideal_explicit2[OF f3] by blast + let ?g = "(\i. if i = x then (f (u*x) *u) * x else g i * i)" + let ?g' = "\i. if i = x then f (u*x) * u else g i" + have sum_rw2: "sum (\i. g i * i) S = sum ?g S" by (rule sum.cong, insert inj_ux ux_notin, auto) + have "a = (\i\(insert (u * x) ((*) u ` S)). f i * i)" using sum_rw by simp + also have "... = ?f (u*x) + sum ?f (((*) u ` S))" + by (rule sum.insert[OF f4], insert inj_ux) (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI + inv_u local.insert(2) local.mult_1_left local.semiring_normalization_rules(18) subsetI) + also have "... = ?f (u*x) + sum (\i. g i * i) S" unfolding sum_rw1 by auto + also have "... = ?g x + sum ?g S" unfolding sum_rw2 using mult.assoc by auto + also have "... = sum ?g (insert x S)" by (rule sum.insert[symmetric, OF f3 insert.hyps(2)]) + also have "... = sum (\i. ?g' i * i) (insert x S)" by (rule sum.cong, auto) + finally show ?thesis by fast + qed + ultimately show ?thesis by blast + qed + also have "... = ideal_generated (insert x S)" using ideal_explicit2[OF f2] by auto + finally show ?case by auto +qed + +corollary ideal_generated_mult_unit2: + assumes u: "u dvd 1" + shows "ideal_generated {u*a,u*b} = ideal_generated {a,b}" +proof - + let ?S = "{a,b}" + have "ideal_generated {u*a,u*b} = ideal_generated ((\x. u*x)` {a,b})" by auto + also have "... = ideal_generated {a,b}" by (rule ideal_generated_mult_unit[OF _ u], simp) + finally show ?thesis . +qed + +lemma ideal_generated_1[simp]: "ideal_generated {1} = UNIV" + by (metis ideal_generated_unit dvd_ideal_generated_singleton order_refl) + +lemma ideal_generated_pair: "ideal_generated {a,b} = {p*a+q*b | p q. True}" +proof - + have i: "ideal_generated {a,b} = {y. \f. (\i\{a,b}. f i * i) = y}" using ideal_explicit2 by auto + show ?thesis + proof (cases "a=b") + case True + show ?thesis using True i + by (auto, metis mult_ac(2) semiring_normalization_rules) + (metis (no_types, hide_lams) add_minus_cancel mult_ac ring_distribs semiring_normalization_rules) + next + case False + have 1: "\p q. (\i\{a, b}. f i * i) = p * a + q * b" for f + by (rule exI[of _ "f a"], rule exI[of _ "f b"], rule sum_two_elements[OF False]) + moreover have "\f. (\i\{a, b}. f i * i) = p * a + q * b" for p q + by (rule exI[of _ "\i. if i=a then p else q"], + unfold sum_two_elements[OF False], insert False, auto) + ultimately show ?thesis using i by auto + qed +qed + +lemma ideal_generated_pair_exists_pq1: + assumes i: "ideal_generated {a,b} = (UNIV::'a set)" + shows "\p q. p*a + q*b = 1" + using i unfolding ideal_generated_pair + by (smt iso_tuple_UNIV_I mem_Collect_eq) + +lemma ideal_generated_pair_UNIV: + assumes sa_tb_u: "s*a+t*b = u" and u: "u dvd 1" + shows "ideal_generated {a,b} = UNIV" +proof - + have f: "finite {a,b}" by simp + obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def + by (metis mult.commute) + have "x \ ideal_generated {a,b}" for x + proof (cases "a = b") + case True + then show ?thesis + by (metis UNIV_I dvd_def dvd_ideal_generated_singleton' ideal_generated_unit insert_absorb2 + mult.commute sa_tb_u semiring_normalization_rules(34) subsetI subset_antisym u) + next + case False note a_not_b = False + let ?f = "\y. if y = a then inv_u * x * s else inv_u * x * t" + have "(\i\{a,b}. ?f i * i) = ?f a * a + ?f b * b" by (rule sum_two_elements[OF a_not_b]) + also have "... = x" using a_not_b sa_tb_u inv_u + by (auto, metis mult_ac(1) mult_ac(2) ring_distribs(1) semiring_normalization_rules(12)) + finally show ?thesis unfolding ideal_explicit2[OF f] by auto + qed + thus ?thesis by auto +qed + + +lemma ideal_generated_pair_exists: + assumes l: "(ideal_generated {a,b} = ideal_generated {d})" + shows "(\ p q. p*a+q*b = d)" +proof - + have d: "d \ ideal_generated {d}" by (simp add: ideal_generated_in) + hence "d \ ideal_generated {a,b}" using l by auto + from this obtain p q where "d = p*a+q*b" using ideal_generated_pair[of a b] by auto + thus ?thesis by auto +qed + + +lemma obtain_ideal_generated_pair: + assumes "c \ ideal_generated {a,b}" + obtains p q where "p*a+q*b=c" +proof - + have "c \ {p * a + q * b |p q. True}" using assms ideal_generated_pair by auto + thus ?thesis using that by auto +qed + +lemma ideal_generated_pair_exists_UNIV: + shows "(ideal_generated {a,b} = ideal_generated {1}) = (\p q. p*a+q*b = 1)" (is "?lhs = ?rhs") +proof + assume r: ?rhs + have "x \ ideal_generated {a,b}" for x + proof (cases "a=b") + case True + then show ?thesis + by (metis UNIV_I r dvd_ideal_generated_singleton finite.intros ideal_generated_1 + ideal_generated_pair_UNIV ideal_generated_singleton_subset) + next + case False + have f: "finite {a,b}" by simp + have 1: "1 \ ideal_generated {a,b}" + using ideal_generated_pair_UNIV local.one_dvd r by blast + hence i: "ideal_generated {a,b} = {y. \f. (\i\{a,b}. f i * i) = y}" + using ideal_explicit2[of "{a,b}"] by auto + from this obtain f where f: "f a * a + f b * b = 1" using sum_two_elements 1 False by auto + let ?f = "\y. if y = a then x * f a else x * f b" + have "(\i\{a,b}. ?f i * i) = x" unfolding sum_two_elements[OF False] using f False + using mult_ac(1) ring_distribs(1) semiring_normalization_rules(12) by force + thus ?thesis unfolding i by auto + qed + thus ?lhs by auto +next + assume ?lhs thus ?rhs using ideal_generated_pair_exists[of a b 1] by auto +qed + +corollary ideal_generated_UNIV_obtain_pair: + assumes "ideal_generated {a,b} = ideal_generated {1}" + shows " (\p q. p*a+q*b = d)" +proof - + obtain x y where "x*a+y*b = 1" using ideal_generated_pair_exists_UNIV assms by auto + hence "d*x*a+d*y*b=d" + using local.mult_ac(1) local.ring_distribs(1) local.semiring_normalization_rules(12) by force + thus ?thesis by auto +qed + + + +lemma sum_three_elements: + shows "\x y z::'a. (\i\{a,b,c}. f i * i) = x * a + y * b + z * c" +proof (cases "a \ b \ b \ c \ a \ c") + case True + then show ?thesis by (auto, metis add.assoc) +next + case False + have 1: "\x y z. f c * c = x * c + y * c + z * c" + by (rule exI[of _ 0],rule exI[of _ 0], rule exI[of _ "f c"], auto) + have 2: "\x y z. f b * b + f c * c = x * b + y * b + z * c" + by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], auto) + have 3: "\x y z. f a * a + f c * c = x * a + y * c + z * c" + by (rule exI[of _ "f a"],rule exI[of _ 0], rule exI[of _ "f c"], auto) + have 4: "\x y z. (\i\{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b \ c" + by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], insert a b, + auto simp add: insert_commute) + show ?thesis using False + by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4) +qed + +lemma sum_three_elements': + shows "\f::'a\'a. (\i\{a,b,c}. f i * i) = x * a + y * b + z * c" +proof (cases "a \ b \ b \ c \ a \ c") + case True + let ?f = "\i. if i = a then x else if i = b then y else if i = c then z else 0" + show ?thesis by (rule exI[of _ "?f"], insert True mult.assoc, auto simp add: local.add_ac) +next + case False + have 1: "\f. f c * c = x * c + y * c + z * c" + by (rule exI[of _ "\i. if i = c then x+y+z else 0"], auto simp add: local.ring_distribs) + have 2: "\f. f a * a + f c * c = x * a + y * c + z * c" if bc: " b = c" and ac: "a \ c" + by (rule exI[of _ "\i. if i = a then x else y+z"], insert ac bc add_ac ring_distribs, auto) + have 3: "\f. f b * b + f c * c = x * b + y * b + z * c" if bc: " b \ c" and ac: "a = b" + by (rule exI[of _ "\i. if i = a then x+y else z"], insert ac bc add_ac ring_distribs, auto) + have 4: "\f. (\i\{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b \ c" + by (rule exI[of _ "\i. if i = c then x+z else y"], insert a b add_ac ring_distribs, + auto simp add: insert_commute) + show ?thesis using False + by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4) +qed + + +(*This is generalizable to arbitrary sets.*) +lemma ideal_generated_triple_pair_rewrite: + assumes i1: "ideal_generated {a, b, c} = ideal_generated {d}" + and i2: "ideal_generated {a, b} = ideal_generated {d'}" + shows "ideal_generated{d',c} = ideal_generated {d}" +proof + have d': "d' \ ideal_generated {a,b}" using i2 by (simp add: ideal_generated_in) + show "ideal_generated {d', c} \ ideal_generated {d}" + proof + fix x assume x: "x \ ideal_generated {d', c}" + obtain f1 f2 where f: "f1*d' + f2*c = x" using obtain_ideal_generated_pair[OF x] by auto + obtain g1 g2 where g: "g1*a + g2*b = d'" using obtain_ideal_generated_pair[OF d'] by blast + have 1: "f1*g1*a + f1*g2*b + f2*c = x" + using f g local.ring_distribs(1) local.semiring_normalization_rules(18) by auto + have "x \ ideal_generated {a, b, c}" + proof - + obtain f where "(\i\{a,b,c}. f i * i) = f1*g1*a + f1*g2*b + f2*c" + using sum_three_elements' 1 by blast + moreover have "ideal_generated {a,b,c} = {y. \f. (\i\{a,b,c}. f i * i) = y}" + using ideal_explicit2[of "{a,b,c}"] by simp + ultimately show ?thesis using 1 by auto + qed + thus "x \ ideal_generated {d}" using i1 by auto + qed + show "ideal_generated {d} \ ideal_generated {d', c}" + proof (rule ideal_generated_singleton_subset) + obtain f1 f2 f3 where f: "f1*a + f2*b + f3*c = d" + proof - + have "d \ ideal_generated {a,b,c}" using i1 by (simp add: ideal_generated_in) + from this obtain f where d: "(\i\{a,b,c}. f i * i) = d" + using ideal_explicit2[of "{a,b,c}"] by auto + obtain x y z where "(\i\{a,b,c}. f i * i) = x * a + y * b + z * c" + using sum_three_elements by blast + thus ?thesis using d that by auto + qed + obtain k where k: "f1*a + f2*b = k*d'" + proof - + have "f1*a + f2*b \ ideal_generated{a,b}" using ideal_generated_pair by blast + also have "... = ideal_generated {d'}" using i2 by simp + also have "... = {k*d' |k. k\UNIV}" using ideal_generated_singleton by auto + finally show ?thesis using that by auto + qed + have "k*d'+f3*c=d" using f k by auto + thus "d \ ideal_generated {d', c}" + using ideal_generated_pair by blast + qed (simp) +qed + +lemma ideal_generated_dvd: + assumes i: "ideal_generated {a,b::'a} = ideal_generated{d} " + and a: "d' dvd a" and b: "d' dvd b" +shows "d' dvd d" +proof - + obtain p q where "p*a+q*b = d" + using i ideal_generated_pair_exists by blast + thus ?thesis using a b by auto +qed + +lemma ideal_generated_dvd2: + assumes i: "ideal_generated S = ideal_generated{d::'a} " + and "finite S" + and x: "\x\S. d' dvd x" +shows "d' dvd d" + by (metis assms dvd_ideal_generated_singleton ideal_generated_dvd_subset) + +end + + +subsection \An equivalent characterization of B\'ezout rings\ + +text \The goal of this subsection is to prove that a ring is B\'ezout ring if and only if every + finitely generated ideal is principal.\ + +definition "finitely_generated_ideal I = (ideal I \ (\S. finite S \ ideal_generated S = I))" + +context + assumes "SORT_CONSTRAINT('a::comm_ring_1)" +begin + + +lemma sum_two_elements': + fixes d::'a + assumes s: "(\i\{a,b}. f i * i) = d" + obtains p and q where "d = p * a + q * b" +proof (cases "a=b") + case True + then show ?thesis + by (metis (no_types, lifting) add_diff_cancel_left' emptyE finite.emptyI insert_absorb2 + left_diff_distrib' s sum.insert sum_singleton that) +next + case False + show ?thesis using s unfolding sum_two_elements[OF False] + using that by auto +qed + +text \This proof follows Theorem 6-3 in "First Course in Rings and Ideals" by Burton\ + +lemma all_fin_gen_ideals_are_principal_imp_bezout: + assumes all: "\I::'a set. finitely_generated_ideal I \ principal_ideal I" + shows "OFCLASS ('a, bezout_ring_class)" +proof (intro_classes) + fix a b::'a + obtain d where ideal_d: "ideal_generated {a,b} = ideal_generated {d}" + using all unfolding finitely_generated_ideal_def + by (metis finite.emptyI finite_insert ideal_ideal_generated principal_ideal_def) + have a_in_d: "a \ ideal_generated {d}" + using ideal_d ideal_generated_subset_generator by auto + have b_in_d: "b \ ideal_generated {d}" + using ideal_d ideal_generated_subset_generator by auto + have d_in_ab: "d \ ideal_generated {a,b}" + using ideal_d ideal_generated_subset_generator by auto + obtain f where "(\i\{a,b}. f i * i) = d" using obtain_sum_ideal_generated[OF d_in_ab] by auto + from this obtain p q where d_eq: "d = p*a + q*b" using sum_two_elements' by blast + moreover have d_dvd_a: "d dvd a" + by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset insert_commute + subset_insertI) + moreover have "d dvd b" + by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset subset_insertI) + moreover have "d' dvd d" if d'_dvd: "d' dvd a \ d' dvd b" for d' + proof - + obtain s1 s2 where s1_dvd: "a = s1*d'" and s2_dvd: "b = s2*d'" + using mult.commute d'_dvd unfolding dvd_def by auto + have "d = p*a + q*b" using d_eq . + also have "...= p * s1 * d' + q * s2 *d'" unfolding s1_dvd s2_dvd by auto + also have "... = (p * s1 + q * s2) * d'" by (simp add: ring_class.ring_distribs(2)) + finally show "d' dvd d" using mult.commute unfolding dvd_def by auto + qed + ultimately show "\p q d. p * a + q * b = d \ d dvd a \ d dvd b + \ (\d'. d' dvd a \ d' dvd b \ d' dvd d)" by auto +qed +end + + +context bezout_ring +begin + +lemma exists_bezout_extended: + assumes S: "finite S" and ne: "S \ {}" + shows "\f d. (\a\S. f a * a) = d \ (\a\S. d dvd a) \ (\d'. (\a\S. d' dvd a) \ d' dvd d)" + using S ne +proof (induct S) + case empty + then show ?case by auto +next + case (insert x S) + show ?case + proof (cases "S={}") + case True + let ?f = "\x. 1" + show ?thesis by (rule exI[of _ ?f], insert True, auto) + next + case False note ne = False + note x_notin_S = insert.hyps(2) + obtain f d where sum_eq_d: "(\a\S. f a * a) = d" + and d_dvd_each_a: "(\a\S. d dvd a)" + and d_is_gcd: "(\d'. (\a\S. d' dvd a) \ d' dvd d)" + using insert.hyps(3)[OF ne] by auto + have "\p q d'. p * d + q * x = d' \ d' dvd d \ d' dvd x \ (\c. c dvd d \ c dvd x \ c dvd d')" + using exists_bezout by auto + from this obtain p q d' where pd_qx_d': "p*d + q*x = d'" + and d'_dvd_d: "d' dvd d" and d'_dvd_x: "d' dvd x" + and d'_dvd: "\c. (c dvd d \ c dvd x) \ c dvd d'" by blast + let ?f = "\a. if a = x then q else p * f a" + have "(\a\insert x S. ?f a * a) = d'" + proof - + have "(\a\insert x S. ?f a * a) = (\a\S. ?f a * a) + ?f x * x" + by (simp add: add_commute insert.hyps(1) insert.hyps(2)) + also have "... = p * (\a\S. f a * a) + q * x" + unfolding sum_distrib_left + by (auto, rule sum.cong, insert x_notin_S, + auto simp add: mult.semigroup_axioms semigroup.assoc) + finally show ?thesis using pd_qx_d' sum_eq_d by auto + qed + moreover have "(\a\insert x S. d' dvd a)" + by (metis d'_dvd_d d'_dvd_x d_dvd_each_a insert_iff local.dvdE local.dvd_mult_left) + moreover have " (\c. (\a\insert x S. c dvd a) \ c dvd d')" + by (simp add: d'_dvd d_is_gcd) + ultimately show ?thesis by auto + qed +qed + +end + +lemma ideal_generated_empty: "ideal_generated {} = {0}" + unfolding ideal_generated_def using ideal_generated_0 + by (metis empty_subsetI ideal_generated_def ideal_generated_subset ideal_ideal_generated + ideal_not_empty subset_singletonD) + + +lemma bezout_imp_all_fin_gen_ideals_are_principal: + fixes I::"'a :: bezout_ring set" + assumes fin: "finitely_generated_ideal I" + shows "principal_ideal I" +proof - + obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I" + using fin unfolding finitely_generated_ideal_def by auto + show ?thesis + proof (cases "S = {}") + case True + then show ?thesis + using ideal_gen_S unfolding True + using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce + next + case False note ne = False + obtain d f where sum_S_d: "(\i\S. f i * i) = d" + and d_dvd_a: "(\a\S. d dvd a)" and d_is_gcd: "(\d'. (\a\S. d' dvd a) \ d' dvd d)" + using exists_bezout_extended[OF fin_S ne] by auto + have d_in_S: "d \ ideal_generated S" + by (metis fin_S ideal_def ideal_generated_subset_generator + ideal_ideal_generated sum_S_d sum_left_ideal) + have "ideal_generated {d} \ ideal_generated S" + by (rule ideal_generated_singleton_subset[OF d_in_S fin_S]) + moreover have "ideal_generated S \ ideal_generated {d}" + proof + fix x assume x_in_S: "x \ ideal_generated S" + obtain f where sum_S_x: "(\a\S. f a * a) = x" + using fin_S obtain_sum_ideal_generated x_in_S by blast + have d_dvd_each_a: "\k. a = k * d" if "a \ S" for a + by (metis d_dvd_a dvdE mult.commute that) + let ?g = "\a. SOME k. a = k*d" + have "x = (\a\S. f a * a)" using sum_S_x by simp + also have "... = (\a\S. f a * (?g a * d))" + proof (rule sum.cong) + fix a assume a_in_S: "a \ S" + obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto + have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd) + thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto + qed (simp) + also have "... = (\a\S. f a * ?g a * d)" by (rule sum.cong, auto) + also have "... = (\a\S. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto + finally show "x \ ideal_generated {d}" + by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right + ideal_generated_in singletonI) + qed + ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto + qed +qed + +text \Now we have the required lemmas to prove the theorem that states that + a ring is B\'ezout ring if and only if every + finitely generated ideal is principal. They are the following ones. + +\begin{itemize} +\item @{text "all_fin_gen_ideals_are_principal_imp_bezout"} +\item @{text "bezout_imp_all_fin_gen_ideals_are_principal"} +\end{itemize} + +However, in order to prove the final lemma, we need the lemmas with no type restrictions. +For instance, we need a version of theorem @{text "bezout_imp_all_fin_gen_ideals_are_principal"} +as + +@{text "OFCLASS('a,bezout_ring) \"} the theorem with generic types + (i.e., @{text "'a"} with no type restrictions) + + +or as + +@{text "class.bezout_ring _ _ _ _ \"} the theorem with generic + types (i.e., @{text "'a"} with no type restrictions) +\ + +(*A possible workaround is to adapt the proof*) +(* +lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory: + assumes a1: "class.bezout_ring ( * ) (1::'a::comm_ring_1) (+) 0 (-) uminus" (*Me da igual esto que OFCLASS*) + shows "\I::'a set. finitely_generated_ideal I \ principal_ideal I" +proof (rule allI, rule impI) + fix I::"'a set" assume fin: "finitely_generated_ideal I" + interpret a: bezout_ring "( * )" "(1::'a)" "(+)" 0 "(-)" uminus using a1 . + interpret dvd "( * )::'a\'a\'a" . + interpret b: comm_monoid_add "(+)" "(0::'a)" using a1 by intro_locales + have c: " class.comm_monoid_add (+) (0::'a)" using a1 by intro_locales + have [simp]: "(dvd.dvd ( * ) d a) = (d dvd a)" for d a::'a + by (auto simp add: dvd.dvd_def dvd_def) + have [simp]: "comm_monoid_add.sum (+) 0 (\a. f a * a) S = sum (\a. f a * a) S" + for f and S::"'a set" + unfolding sum_def unfolding comm_monoid_add.sum_def[OF c] .. + obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I" + using fin unfolding finitely_generated_ideal_def by auto + show "principal_ideal I" + proof (cases "S = {}") + case True + then show ?thesis + using ideal_gen_S unfolding True + using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce + next + case False note ne = False + obtain d f where sum_S_d: "(\i\S. f i * i) = d" + and d_dvd_a: "(\a\S. d dvd a)" and d_is_gcd: "(\d'. (\a\S. d' dvd a) \ d' dvd d)" + using a.exists_bezout_extended[OF fin_S ne] by auto + have d_in_S: "d \ ideal_generated S" + by (metis fin_S ideal_def ideal_generated_subset_generator + ideal_ideal_generated sum_S_d sum_left_ideal) + have "ideal_generated {d} \ ideal_generated S" + by (rule ideal_generated_singleton_subset[OF d_in_S fin_S]) + moreover have "ideal_generated S \ ideal_generated {d}" + proof + fix x assume x_in_S: "x \ ideal_generated S" + obtain f where sum_S_x: "(\a\S. f a * a) = x" + using fin_S obtain_sum_ideal_generated x_in_S by blast + have d_dvd_each_a: "\k. a = k * d" if "a \ S" for a + by (metis d_dvd_a dvdE mult.commute that) + let ?g = "\a. SOME k. a = k*d" + have "x = (\a\S. f a * a)" using sum_S_x by simp + also have "... = (\a\S. f a * (?g a * d))" + proof (rule sum.cong) + fix a assume a_in_S: "a \ S" + obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto + have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd) + thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto + qed (simp) + also have "... = (\a\S. f a * ?g a * d)" by (rule sum.cong, auto) + also have "... = (\a\S. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto + finally show "x \ ideal_generated {d}" + by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right + ideal_generated_in singletonI) + qed + ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto + qed +qed +*) + +text \Thanks to local type definitions, we can obtain it automatically by means + of @{text "internalize-sort"}.\ + +lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory: + assumes a1: "class.bezout_ring (*) (1::'b::comm_ring_1) (+) 0 (-) uminus" (*It is algo possible to prove it using OFCLASS*) + shows "\I::'b set. finitely_generated_ideal I \ principal_ideal I" + using bezout_imp_all_fin_gen_ideals_are_principal[internalize_sort "'a::bezout_ring"] + using a1 by auto + + +text \The standard library does not connect @{text "OFCLASS"} and @{text "class.bezout_ring"} +in both directions. Here we show that @{text "OFCLASS \ class.bezout_ring"}. \ + +lemma OFCLASS_bezout_ring_imp_class_bezout_ring: + assumes "OFCLASS('a::comm_ring_1,bezout_ring_class)" + shows "class.bezout_ring ((*)::'a\'a\'a) 1 (+) 0 (-) uminus" + using assms + unfolding bezout_ring_class_def class.bezout_ring_def + using conjunctionD2[of "OFCLASS('a, comm_ring_1_class)" + "class.bezout_ring_axioms ((*)::'a\'a\'a) (+)"] + by (auto, intro_locales) + +text \The other implication can be obtained + by thm @{text "Rings2.class.Rings2.bezout_ring.of_class.intro"} \ +thm Rings2.class.Rings2.bezout_ring.of_class.intro + + +(*OFCLASS is a proposition (Prop), and then the following statement is not valid.*) + +(* +lemma + shows "(\I::'a::comm_ring_1 set. finitely_generated_ideal I \ principal_ideal I) + = OFCLASS('a, bezout_ring_class)" +*) + +(*Thus, we use the meta-equality and the meta universal quantifier.*) +text \Final theorem (with OFCLASS)\ +lemma bezout_ring_iff_fin_gen_principal_ideal: + "(\I::'a::comm_ring_1 set. finitely_generated_ideal I \ principal_ideal I) + \ OFCLASS('a, bezout_ring_class)" +proof + show "(\I::'a::comm_ring_1 set. finitely_generated_ideal I \ principal_ideal I) + \ OFCLASS('a, bezout_ring_class)" + using all_fin_gen_ideals_are_principal_imp_bezout [where ?'a='a] by auto + show "\I::'a::comm_ring_1 set. OFCLASS('a, bezout_ring_class) + \ finitely_generated_ideal I \ principal_ideal I" + using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory[where ?'b='a] + using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a] by auto +qed + +text \Final theorem (with @{text "class.bezout_ring"})\ + +lemma bezout_ring_iff_fin_gen_principal_ideal2: + "(\I::'a::comm_ring_1 set. finitely_generated_ideal I \ principal_ideal I) + = (class.bezout_ring ((*)::'a\'a\'a) 1 (+) 0 (-) uminus)" +proof + show "\I::'a::comm_ring_1 set. finitely_generated_ideal I \ principal_ideal I + \ class.bezout_ring (*) 1 (+) (0::'a) (-) uminus" + using all_fin_gen_ideals_are_principal_imp_bezout[where ?'a='a] + using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a] + by auto + show "class.bezout_ring (*) 1 (+) (0::'a) (-) uminus \ \I::'a set. + finitely_generated_ideal I \ principal_ideal I" + using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory by auto +qed + +end diff --git a/thys/Smith_Normal_Form/SNF_Algorithm.thy b/thys/Smith_Normal_Form/SNF_Algorithm.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Algorithm.thy @@ -0,0 +1,2442 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \A general algorithm to transform a matrix into its Smith normal form\ + +theory SNF_Algorithm + imports + Smith_Normal_Form_JNF +begin + +text \This theory presents an executable algorithm to transform a matrix +to its Smith normal form.\ + +subsection \Previous definitions and lemmas\ + +definition "is_SNF A R = (case R of (P,S,Q) \ + P \ carrier_mat (dim_row A) (dim_row A) \ + Q \ carrier_mat (dim_col A) (dim_col A) + \ invertible_mat P \ invertible_mat Q + \ Smith_normal_form_mat S \ S = P * A * Q)" + + +lemma is_SNF_intro: + assumes "P \ carrier_mat (dim_row A) (dim_row A)" + and "Q \ carrier_mat (dim_col A) (dim_col A) " + and "invertible_mat P" and "invertible_mat Q" + and "Smith_normal_form_mat S" and "S = P * A * Q" +shows "is_SNF A (P,S,Q)" using assms unfolding is_SNF_def by auto + + +(*With the following lemmas, we show that for the case 1xn only column operations are needed + and the algorithm just needs to return two matrices.*) + +lemma Smith_1xn_two_matrices: + fixes A :: "'a::comm_ring_1 mat" + assumes A: "A \ carrier_mat 1 n" + and PSQ: "(P,S,Q) = (Smith_1xn A)" + and is_SNF: "is_SNF A (Smith_1xn A)" +shows "\Smith_1xn'. is_SNF A (1\<^sub>m 1, (Smith_1xn' A))" +proof - + let ?Q = "P$$(0,0) \\<^sub>m Q" + have P00_dvd_1: "P $$ (0, 0) dvd 1" + by (metis (mono_tags, lifting) assms carrier_matD(1) determinant_one_element + invertible_iff_is_unit_JNF is_SNF_def prod.simps(2)) + have "is_SNF A (1\<^sub>m 1,S,?Q)" + proof (rule is_SNF_intro) + show "invertible_mat (P $$ (0, 0) \\<^sub>m Q)" + by (rule invertible_mat_smult_mat, insert P00_dvd_1 assms, auto simp add: is_SNF_def) + show "S = 1\<^sub>m 1 * A * (P $$ (0, 0) \\<^sub>m Q)" + by (smt A PSQ is_SNF carrier_matD(2) index_mult_mat(2) index_one_mat(2) left_mult_one_mat + mult_smult_assoc_mat mult_smult_distrib smult_mat_mat_one_element is_SNF_def split_conv) + qed (insert assms, auto simp add: is_SNF_def) + thus ?thesis by auto +qed + +lemma Smith_1xn_two_matrices_all: + assumes is_SNF: "\(A::'a::comm_ring_1 mat) \ carrier_mat 1 n. is_SNF A (Smith_1xn A)" + shows "\Smith_1xn'. \(A::'a::comm_ring_1 mat) \ carrier_mat 1 n. is_SNF A (1\<^sub>m 1, (Smith_1xn' A))" +proof - + let ?Smith_1xn' = "\A. let (P,S,Q) = (Smith_1xn A) in (S, P $$ (0, 0) \\<^sub>m Q)" + show ?thesis by (rule exI[of _ ?Smith_1xn']) (smt Smith_1xn_two_matrices assms carrier_matD + carrier_matI case_prodE determinant_one_element index_smult_mat(2,3) invertible_iff_is_unit_JNF + invertible_mat_smult_mat smult_mat_mat_one_element left_mult_one_mat is_SNF_def + mult_smult_assoc_mat mult_smult_distrib prod.simps(2)) +qed + +subsection \Previous operations\ +(*Reduce column, parameterized by a div operation*) +context +assumes "SORT_CONSTRAINT('a::comm_ring_1)" +begin + +definition is_div_op :: "('a\'a\'a) \bool" + where "is_div_op div_op = (\a b. b dvd a \ div_op a b * b = a)" + +(* With SOME, we can get a (non-executable) div operation:*) +lemma div_op_SOME: "is_div_op (\a b. (SOME k. k * b = a))" +proof (unfold is_div_op_def, rule+) + fix a b::'a assume dvd: "b dvd a" + show "(SOME k. k * b = a) * b = a" by (rule someI_ex, insert dvd dvd_def) (metis dvdE mult.commute) +qed + +fun reduce_column_aux :: "('a\'a\'a) \ nat list \ 'a mat \ ('a mat \ 'a mat) \ ('a mat \ 'a mat)" + where "reduce_column_aux div_op [] H (P,K) = (P,K)" + | "reduce_column_aux div_op (i#xs) H (P,K) = ( + \ \Reduce the i-th row\ + let k = div_op (H$$(i,0)) (H $$ (0, 0)); + P' = addrow_mat (dim_row H) (-k) i 0; + K' = addrow (-k) i 0 K + in reduce_column_aux div_op xs H (P'*P,K') + )" + +definition "reduce_column div_op H = reduce_column_aux div_op [2..m (dim_row H),H)" + + +lemma reduce_column_aux: + assumes H: "H \ carrier_mat m n" + and P_init: "P_init \ carrier_mat m m" + and K_init: "K_init \ carrier_mat m n" + and P_init_H_K_init: "P_init * H = K_init" + and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)" + and m: "0 < m" + and inv_P: "invertible_mat P_init" + and xs: "0 \ set xs" +shows "P \ carrier_mat m m \ K \ carrier_mat m n \ P * H = K \ invertible_mat P" + using assms + unfolding reduce_column_def +proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init rule: reduce_column_aux.induct) + case (1 div_op H P K) + then show ?case by simp +next + case (2 div_op i xs H P_init K_init) + show ?case + proof (rule "2.hyps") + let ?x = "div_op (H $$ (i, 0)) (H $$ (0, 0))" + let ?xa = "addrow_mat (dim_row H) (- ?x) i 0" + let ?xb = "addrow (- ?x) i 0 K_init" + show "(P, K) = reduce_column_aux div_op xs H (?xa * P_init, ?xb)" + using "2.prems" by (auto simp add: Let_def) + show "?xa * P_init \ carrier_mat m m" using "2"(2) "2"(3) by auto + show "0 \ set xs" using "2.prems" by auto + have "?xa * K_init = ?xb" + by (rule addrow_mat[symmetric], insert "2.prems", auto) + thus "?xa * P_init * H = ?xb" + by (metis (no_types, lifting) "2"(5) "2.prems"(1) "2.prems"(2) addrow_mat_carrier + assoc_mult_mat carrier_matD(1)) + show "invertible_mat (?xa * P_init)" + proof (rule invertible_mult_JNF) + show xa: "?xa \ carrier_mat m m" using "2"(2) by auto + have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto) + thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp + qed (auto simp add: "2.prems") + qed(auto simp add: "2.prems") + qed + + +lemma reduce_column_aux_preserves: + assumes H: "H \ carrier_mat m n" + and P_init: "P_init \ carrier_mat m m" + and K_init: "K_init \ carrier_mat m n" + and P_init_H_K_init: "P_init * H = K_init" + and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)" + and m: "0 < m" + and inv_P: "invertible_mat P_init" + and xs: "0 \ set xs" and i: "i \ set xs" and im: "i carrier_mat m m" + using "2"(4) "2"(5) by auto + have "?xa * K_init = ?xb" + by (rule addrow_mat[symmetric], insert "2.prems", auto) + show "invertible_mat (?xa * P_init)" + proof (rule invertible_mult_JNF) + show xa: "?xa \ carrier_mat m m" using "2.prems" by auto + have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto) + thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp + qed (auto simp add: "2.prems") + show "i \ set xs" using "2"(9) by auto + show "0 \ set xs" using "2"(8) by auto + qed(auto simp add: "2.prems") + also have "... = Matrix.row K_init i" + by (rule eq_vecI, auto, insert "2" "2.prems" im, auto) + finally show ?case . +qed + +lemma reduce_column_aux_index': + assumes H: "H \ carrier_mat m n" + and P_init: "P_init \ carrier_mat m m" + and K_init: "K_init \ carrier_mat m n" + and P_init_H_K_init: "P_init * H = K_init" + and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)" + and m: "0 < m" + and inv_P: "invertible_mat P_init" + and xs: "0 \ set xs" + and "\x\set xs. xi\set xs. Matrix.row K i = + Matrix.row (addrow (-(div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init) i)" + using assms + unfolding reduce_column_def +proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init K rule: reduce_column_aux.induct) + case (1 div_op H P K) + then show ?case by simp +next + case (2 div_op i xs H P_init K_init) + let ?x = "div_op (H $$ (i, 0)) (H $$ (0, 0)) " + let ?xa = "addrow_mat (dim_row H) ?x i 0" + thm "2.prems" + thm "2.hyps" + let ?xb = "addrow (- ?x) i 0 K_init" + let ?xa = "addrow_mat (dim_row H) (- ?x) i 0" + have "reduce_column_aux div_op (i#xs) H (P_init,K_init) + = reduce_column_aux div_op xs H (?xa*P_init,?xb)" + by (auto simp add: Let_def) + hence PK: "(P,K) = reduce_column_aux div_op xs H (?xa*P_init,?xb)" using "2.prems" by simp + have xa_P_init: "?xa * P_init \ carrier_mat m m" using "2"(2) "2"(3) by auto + have zero_notin_xs: "0 \ set xs" using "2.prems" by auto + have "?xa * K_init = ?xb" + by (rule addrow_mat[symmetric], insert "2.prems", auto) + hence rw: "?xa * P_init * H = ?xb" + by (metis (no_types, lifting) "2"(5) "2.prems"(1) "2.prems"(2) addrow_mat_carrier + assoc_mult_mat carrier_matD(1)) + have inv_xa_P_init: "invertible_mat (?xa * P_init)" + proof (rule invertible_mult_JNF) + show xa: "?xa \ carrier_mat m m" using "2"(2) by auto + have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto) + thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp + qed (auto simp add: "2.prems") + have i1: "i\0" using "2.prems"(8) by auto + have i2: "iset xs" using 2 by auto + have d: "distinct xs" using 2 by auto + have "\i\set xs. Matrix.row K i = Matrix.row (addrow (- (div_op (H $$ (i, 0)) (H $$ (0, 0)))) + i 0 ?xb) i" + by (rule "2.hyps", insert xa_P_init zero_notin_xs rw inv_xa_P_init d, + auto simp add: "2.prems" Let_def) + moreover have "Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 ?xb) j + = Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 K_init) j" + (is "Matrix.row ?lhs j= Matrix.row ?rhs j") + if j: "j \ set xs" for j + proof (rule eq_vecI) + fix ia assume ia: "iaj\set xs. Matrix.row K j = + Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 K_init) j" by auto + moreover have "Matrix.row K i = Matrix.row ?xb i" + by (rule reduce_column_aux_preserves[OF _ xa_P_init _ rw PK _ inv_xa_P_init zero_notin_xs + i3 i2],insert "2.prems", auto) + ultimately show ?case by auto + qed + +corollary reduce_column_aux_index: + assumes H: "H \ carrier_mat m n" + and P_init: "P_init \ carrier_mat m m" + and K_init: "K_init \ carrier_mat m n" + and P_init_H_K_init: "P_init * H = K_init" + and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)" + and m: "0 < m" + and inv_P: "invertible_mat P_init" + and xs: "0 \ set xs" + and "\x\set xs. xset xs" +shows "Matrix.row K i = + Matrix.row (addrow (-(div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init) i" + using reduce_column_aux_index' assms by simp + + +corollary reduce_column_aux_works: + assumes H: "H \ carrier_mat m n" + and PK_H: "(P,K) = reduce_column_aux div_op xs H (1\<^sub>m (dim_row H), H)" + and m: "0 < m" + and xs: "0 \ set xs" + and xm: "\x \ set xs. x set xs" + and dvd: "H $$ (0, 0) dvd H $$ (i, 0)" + and j0: "\j\{1..{1.. carrier_mat m n" + and PK_H: "(P,K) = reduce_column div_op H" + and m: "0 < m" +shows "P \ carrier_mat m m \ K \ carrier_mat m n \ P * H = K \ invertible_mat P" + by (rule reduce_column_aux[OF _ _ _ _ PK_H[unfolded reduce_column_def]], insert assms, auto) + +lemma reduce_column_preserves: + assumes H: "H \ carrier_mat m n" + and PK_H: "(P,K) = reduce_column div_op H" + and m: "0 < m" + and "i\{0,1}" + and "i carrier_mat m n" + and PK_H: "(P,K) = reduce_column div_op H" + and m: "0 < m" and i: "i\{0,1}" and im: "i carrier_mat m n" + and PK_H: "(P,K) = reduce_column div_op H" + and m: "0 < m" + and dvd: "H $$ (0, 0) dvd H $$ (i, 0)" + and j0: "\j\{1..{1..{2..The implementation\ + +text \We define a locale where we implement the algorithm. It has three fixed operations: +\begin{enumerate} +\item an operation to transform any $1 \times 2$ matrix into its Smith normal form +\item an operation to transform any $2 \times 2$ matrix into its Smith normal form +\item an operation that provides a witness for division (this operation always exists over a + commutative ring with unit, but maybe we cannot provide a computable algorithm). +\end{enumerate} + +Since we are working in a commutative ring, we can easily get an operation for $2 \times 1$ matrices +via the $1 \times 2$ operation. +\ +locale Smith_Impl = + fixes Smith_1x2 :: "('a::comm_ring_1) mat \ ('a mat \ 'a mat)" + and Smith_2x2 :: "'a mat \ ('a mat \ 'a mat \ 'a mat)" + and div_op :: "'a\'a\'a" + assumes SNF_1x2_works: "\(A::'a mat) \ carrier_mat 1 2. is_SNF A (1\<^sub>m 1, (Smith_1x2 A))" + and SNF_2x2_works: "\(A::'a mat) \ carrier_mat 2 2. is_SNF A (Smith_2x2 A)" + and id: "is_div_op div_op" +begin + +text \From a $2 \times 2$ matrix (the $B$), we construct the identity matrix of size $n$ with +the elements of $B$ placed to modify the first element of a matrix and the element in position +$(k,k)$\ + +definition "make_mat n k (B::'a mat) = (Matrix.mat n n (\(i,j). if i = 0 \ j = 0 then B$$(0,0) else + if i = 0 \ j = k then B$$(0,1) else if i=k \ j = 0 + then B$$(1,0) else if i=k \ j=k then B$$(1,1) + else if i=j then 1 else 0))" + +lemma make_mat_carrier[simp]: + shows "make_mat n k B \ carrier_mat n n" + unfolding make_mat_def by auto + +lemma upper_triangular_mat_delete_make_mat: + shows "upper_triangular (mat_delete (make_mat n k B) 0 0)" +proof - + { let ?M = "make_mat n k B" + fix i j + assume "i < dim_row ?M - Suc 0" and ji: "j < i" + hence i_n1: "i < n - 1" by (simp add: make_mat_def) + hence Suc_i: "Suc i < n" by linarith + hence Suc_j: "Suc j < n" using ji by auto + have i1: "insert_index 0 i = Suc i" by (rule insert_index, auto) + have j1: "insert_index 0 j = Suc j" by (rule insert_index, auto) + have "mat_delete ?M 0 0 $$ (i, j) = ?M $$ (insert_index 0 i, insert_index 0 j)" + by (rule mat_delete_index[symmetric, OF _ _ _ i_n1], insert Suc_i Suc_j, auto) + also have "... = ?M $$ (Suc i, Suc j)" unfolding i1 j1 by simp + also have "... = 0" unfolding make_mat_def unfolding index_mat[OF Suc_i Suc_j] using ji by auto + finally have "mat_delete ?M 0 0 $$ (i, j) = 0" . + } + thus ?thesis unfolding upper_triangular_def by auto +qed + +lemma upper_triangular_mat_delete_make_mat2: + assumes kn: "k carrier_mat (Suc (n - 2)) (Suc (n - 2))" + by (metis Suc_diff_Suc card_num_simps(30) make_mat_carrier mat_delete_carrier + nat_diff_split_asm not_less0 not_less_eq numerals(2)) + show "k - 1 < Suc (n - 2)" using kn by auto + show "0 < Suc (n - 2)" by blast + show "j < n - 2" using ji i by (simp add: make_mat_def) + qed + also have "... = ?MD $$ (insert_index (k-1) i, Suc j)" unfolding insert_j by auto + also have "... = 0" + proof (cases "i < (k-1)") + case True + hence "insert_index (k-1) i = i" by auto + hence "?MD $$ (insert_index (k-1) i, Suc j) = ?MD $$ (i, Suc j)" by auto + also have "... = ?M $$ (insert_index 0 i, insert_index k (Suc j))" + proof (rule mat_delete_index[symmetric]) + show "?M \ carrier_mat (Suc (n-1)) (Suc (n-1))" using assms by auto + show "0 < Suc (n - 1)" + by blast + show "k < Suc (n - 1)"using kn by simp + show "i < n - 1" using i using True assms by linarith + thus "Suc j < n - 1" using ji less_trans_Suc by blast + qed + also have "... = 0" unfolding make_mat_def index_mat[OF insert_in insert_k_Sucj] + using True ji by auto + finally show ?thesis . + next + case False + hence "insert_index (k-1) i = Suc i" by auto + hence "?MD $$ (insert_index (k-1) i, Suc j) = ?MD $$ (Suc i, Suc j)" by auto + also have "... = ?M $$ (insert_index 0 (Suc i), insert_index k (Suc j))" + proof (rule mat_delete_index[symmetric]) + show "?M \ carrier_mat (Suc (n-1)) (Suc (n-1))" using assms by auto + thus "Suc i < n - 1" using i using False assms + by (metis One_nat_def Suc_diff_Suc carrier_matD(1) diff_Suc_1 diff_Suc_eq_diff_pred + diff_is_0_eq' linorder_not_less nat.distinct(1) numeral_2_eq_2) + show "0 < Suc (n - 1)" + by blast + show "k < Suc (n - 1)"using kn by simp + show "Suc j < n - 1" using ji less_trans_Suc + using \Suc i < n - 1\ by linarith + qed + also have "... = 0" unfolding make_mat_def index_mat[OF insert_Sucin insert_k_Sucj] + using False ji by (auto, smt insert_index_def less_SucI nat.inject nat_neq_iff) + finally show ?thesis . + qed + finally have "mat_delete ?MD (k - 1) 0 $$ (i, j) = 0" . +} + thus ?thesis unfolding upper_triangular_def by auto +qed + +corollary det_mat_delete_make_mat: + assumes kn: "k carrier_mat (Suc (n-2)) (Suc (n-2))" + by (metis (mono_tags, hide_lams) Suc_diff_Suc card_num_simps(30) i make_mat_carrier + mat_delete_carrier nat_diff_split_asm not_less0 not_less_eq numerals(2)) + show "k - 1 < Suc (n - 2)" using kn by auto + show "0 < Suc (n - 2)" using kn by auto + qed + also have "... = ?M $$ (insert_index 0 (insert_index (k-1) i), insert_index k (insert_index 0 i))" + proof (rule mat_delete_index[symmetric]) + show "make_mat n k B \ carrier_mat (Suc (n-1)) (Suc (n-1))" using i by auto + show "insert_index (k - 1) i < n - 1" using kn i + by (metis diff_Suc_eq_diff_pred diff_commute insert_index_def nat_neq_iff not_less0 + numeral_2_eq_2 zero_less_diff) + show "insert_index 0 i < n - 1" using i by auto + qed (insert kn, auto) + also have "... = 1" unfolding make_mat_def index_mat[OF i1 i2] + by (auto, metis One_nat_def diff_Suc_1 insert_index_exclude) + (metis One_nat_def diff_Suc_eq_diff_pred insert_index_def zero_less_diff)+ + finally show ?thesis . + qed + have "Determinant.det ?MDMD = prod_list (diag_mat ?MDMD)" + by (meson assms det_upper_triangular make_mat_carrier mat_delete_carrier + upper_triangular_mat_delete_make_mat2) + also have "... = 1" + proof (rule prod_list_neutral) + fix x assume x: "x \ set (diag_mat ?MDMD)" + from this obtain i where index: "x = ?MDMD $$ (i,i)" and i: "i carrier_mat 2 2" and k0: "k\0" and k: "k0" + shows "cofactor (make_mat n k B) 0 0 = B $$ (1,1)" +proof - + let ?M = "make_mat n k B" + let ?MD = "mat_delete ?M 0 0" + have MD_rows: "dim_row ?MD = n-1" by (simp add: make_mat_def) + have 1: "?MD $$ (i, i) = 1" if i: "i < n - 1" and ik: "Suc i \ k" for i + proof - + have Suc_i: "Suc i < n" using i by linarith + have "?MD $$ (i, i) = ?M $$ (insert_index 0 i, insert_index 0 i)" + by (rule mat_delete_index[symmetric, OF _ _ _ i], insert Suc_i, auto) + also have "... = ?M $$ (Suc i, Suc i)" by simp + also have "... = 1" unfolding make_mat_def index_mat[OF Suc_i Suc_i] using ik by auto + finally show ?thesis . + qed + have 2: "?MD $$ (i, i) = B$$(1,1)" if i: "i < n - 1" and ik: "Suc i = k" for i + proof - + have Suc_i: "Suc i < n" using i by linarith + have "?MD $$ (i, i) = ?M $$ (insert_index 0 i, insert_index 0 i)" + by (rule mat_delete_index[symmetric, OF _ _ _ i], insert Suc_i, auto) + also have "... = ?M $$ (Suc i, Suc i)" by simp + also have "... = B$$(1,1)" unfolding make_mat_def index_mat[OF Suc_i Suc_i] using ik by auto + finally show ?thesis . + qed + have set_rw: "insert (k-1) ({0..i = 0..i \ insert (k-1) ({0..i \ {0..0" and n0: "1 carrier_mat (n-1) (n-1)" + using make_mat_carrier mat_delete_carrier by blast + have MD_k1: "?MD $$ (k-1, 0) = B $$ (1,0)" + proof - + have n0': "0 < n" using n0 by auto + have insert_i: "insert_index 0 (k-1) = k" using k0 by auto + have insert_k: "insert_index k 0 = 0" using k0 by auto + have "?MD $$ (k-1, 0) = ?M $$ (insert_index 0 (k-1), insert_index k 0)" + by (rule mat_delete_index[symmetric, OF _ _ _ _ n0], insert k0 kn, auto) + also have "... = ?M $$ (k, 0)" unfolding insert_i insert_k by simp + also have "... = B $$ (1,0)" using k0 unfolding make_mat_def index_mat[OF kn n0'] by auto + finally show ?thesis . + qed + have MD0: "?MD $$ (i, 0) = 0" if i: "ik" for i + proof - + have i2: "Suc i < n" using i by auto + have n0': "0i\{0..ii\{0.. carrier_mat 2 2" + and kn: "k0" + shows "invertible_mat (make_mat n k B)" +proof - + let ?M = "(make_mat n k B)" + have M_carrier: "?M \ carrier_mat n n" by auto + show ?thesis + proof (cases "n=0") + case True + thus ?thesis using M_carrier using invertible_mat_zero by blast + next + case False note n_not_0 = False + show ?thesis + proof (cases "n=1") + case True + then show ?thesis using M_carrier using invertible_mat_zero assms by auto + next + case False + hence n: "0j\({0.. {0..jj\{0..j\({0.. j = 0 then B$$(0,0) else + if i = 0 \ j = k then B$$(0,1) else if i=k \ j = 0 + then B$$(1,0) else if i=k \ j=k then B$$(1,1) + else if i=j then 1 else 0)" + unfolding make_mat_def index_mat[OF i j] by simp + +lemma make_mat_works: + assumes A: "A\carrier_mat m n" and Suc_i_less_n: "Suc i < n" + and Q_step_def: "Q_step = (make_mat n (Suc i) (snd (Smith_1x2 + (Matrix.mat 1 2 (\(a,b). if b = 0 then A $$ (0,0) else A $$(0,Suc i))))))" + shows "A $$ (0,0) * Q_step $$ (0,(Suc i)) + A $$ (0, Suc i) * Q_step $$ (Suc i, Suc i) = 0" +proof - + have n0: "0m 1, Smith_1x2 ?A)" using SNF_1x2_works by auto + have SNF_S: "Smith_normal_form_mat ?S" and S: "?S = 1\<^sub>m 1 * ?A * ?Q" + and Q: "?Q \ carrier_mat 2 2" + using is_SNF_A' unfolding is_SNF_def by auto + have "?S $$(0,1) = (?A * ?Q) $$(0,1)" unfolding S by auto + also have "... = Matrix.row ?A 0 \ col ?Q 1" by (rule index_mult_mat, insert Q, auto) + also have "... = (\ia = 0..ia \ {0,1}. Matrix.row ?A 0 $v ia * col ?Q 1 $v ia)" + by (rule sum.cong, insert Q, auto) + also have "... = Matrix.row ?A 0 $v 0 * col ?Q 1 $v 0 + Matrix.row ?A 0 $v 1 * col ?Q 1 $v 1" + using sum_two_elements by auto + also have "... = A $$ (0,0) * ?Q $$ (0,1) + A $$ (0,Suc i) * ?Q $$ (1,1)" + by (smt One_nat_def Q carrier_matD(1) carrier_matD(2) dim_col_mat(1) dim_row_mat(1) index_col + index_mat(1) index_row(1) lessI numeral_2_eq_2 pos2 prod.simps(2) rel_simps(93)) + finally have "?S $$(0,1) = A $$ (0,0) * ?Q $$ (0,1) + A $$ (0,Suc i) * ?Q $$ (1,1)" by simp + moreover have "?S $$(0,1) = 0" using SNF_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def + by (metis (no_types, lifting) Q S card_num_simps(30) carrier_matD(2) index_mult_mat(2) + index_mult_mat(3) index_one_mat(2) lessI n_not_Suc_n numeral_2_eq_2) + ultimately show ?thesis using 1 2 unfolding Q_step_def by auto +qed + +subsubsection \Case $1 \times n$\ + +fun Smith_1xn_aux :: "nat \ 'a mat \ ('a mat \ 'a mat) \ ('a mat \ 'a mat)" + where + "Smith_1xn_aux 0 A (S,Q) = (S,Q)" | + "Smith_1xn_aux (Suc i) A (S,Q) = (let + A_step_1x2 = (Matrix.mat 1 2 (\(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i))); + (S_step_1x2, Q_step_1x2) = Smith_1x2 A_step_1x2; + Q_step = make_mat (dim_col A) (Suc i) Q_step_1x2; + S' = S * Q_step + in Smith_1xn_aux i A (S',Q*Q_step))" + +definition "Smith_1xn A = (if dim_col A = 0 then (A,1\<^sub>m (dim_col A)) + else Smith_1xn_aux (dim_col A - 1) A (A,1\<^sub>m (dim_col A)))" + +lemma Smith_1xn_aux_Q_carrier: + assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))" + assumes A: "A \ carrier_mat 1 n" and Q: "Q \ carrier_mat n n" + shows "Q' \ carrier_mat n n" + using A r Q +proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct) + case (1 A S Q) + then show ?case by auto +next + case (2 i A S Q) + note A = "2.prems"(1) + note S'Q' = "2.prems"(2) + note Q = "2.prems"(3) + let ?A_step_1x2 = "(Matrix.mat 1 2 (\(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))" + let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)" + let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)" + let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2" + have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step" + by (smt A Q assoc_mult_mat carrier_matD(2) make_mat_carrier) + have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" + by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv) + show ?case + proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2]) + show "S * ?Q_step = S * ?Q_step" .. + show "A \ carrier_mat 1 n" using A by auto + show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto + show "Q * ?Q_step \ carrier_mat n n" using A Q by auto + qed (auto) +qed + + +lemma Smith_1xn_aux_invertible_Q: + assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))" + assumes A: "A \ carrier_mat 1 n" and Q: "Q \ carrier_mat n n" + and i: "i carrier_mat 1 n" using "2.prems" by auto + show "Q * ?Q_step \ carrier_mat n n" using "2.prems" by auto + show "S * ?Q_step = S * ?Q_step" .. + show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto + show "invertible_mat (Q * ?Q_step)" + proof (rule invertible_mult_JNF) + show "Q \ carrier_mat n n" using "2.prems" by auto + show "?Q_step \ carrier_mat n n" using "2.prems" by auto + show "invertible_mat Q" using "2.prems" by auto + show "invertible_mat ?Q_step" + by (rule invertible_make_mat[OF _ _ i_col], insert SNF_1x2_works, unfold is_SNF_def, auto) + (metis (no_types, lifting) case_prodE mat_carrier snd_conv)+ + qed + qed (auto simp add: i_n) +qed + +lemma Smith_1xn_aux_S'_AQ': + assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))" + assumes A: "A \ carrier_mat 1 n" and S: "S \ carrier_mat 1 n" and Q: "Q \ carrier_mat n n" + and S_AQ: "S = A*Q" and i: "i carrier_mat 1 n" using "2.prems" by auto + show "Q * ?Q_step \ carrier_mat n n" using "2.prems" by auto + show "S * ?Q_step = S * ?Q_step" .. + show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto + show " S * ?Q_step = A * (Q * ?Q_step)" using "2.prems" rw by auto + show "S * ?Q_step \ carrier_mat 1 n" + using "2.prems" by (smt carrier_matD(2) make_mat_carrier mult_carrier_mat) + qed (auto) +qed + + +lemma Smith_1xn_aux_S'_works: + assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))" + assumes A: "A \ carrier_mat 1 n" and S: "S \ carrier_mat 1 n" and Q: "Q \ carrier_mat n n" + and S_AQ: "S = A*Q" and i: "ij\{i+1.. carrier_mat 1 n" using "2.prems" by auto + show Q_Q_step_carrier: "Q * ?Q_step \ carrier_mat n n" using "2.prems" by auto + show "S * ?Q_step = S * ?Q_step" .. + show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto + show "S * ?Q_step = A * (Q * ?Q_step)" using "2.prems" rw by auto + show "S * ?Q_step \ carrier_mat 1 n" + using "2.prems" by (smt carrier_matD(2) make_mat_carrier mult_carrier_mat) + show "\j\{i + 1..{i + 1.. col ?Q_step j" + by (rule index_mult_mat, insert j "2.prems", auto simp add: make_mat_def) + also have "... = 0" + proof (cases "j=Suc i") + case True + (*In this case, the element is transformed into a zero thanks to the SNF operation.*) + let ?f = "\x. Matrix.row S 0 $v x * col ?Q_step j $v x" + let ?set = "{0..x \ ?set - {0} - {j}. ?f x) = 0" + proof (rule sum.neutral, rule ballI) + fix x assume x: "x \ ?set - {0} - {j}" + show "?f x = 0" using "2"(6) "2.prems" True make_mat_def x by auto + qed + have "Matrix.row S 0 \ col ?Q_step j = (\x = 0..x \ insert 0 (insert j (?set - {0} - {j})). ?f x)" using set_rw by auto + also have "... = ?f 0 + (\x \ insert j (?set - {0} - {j}). ?f x)" by (simp add: True) + also have "... = ?f 0 + ?f j + (\x \ ?set - {0} - {j}. ?f x)" + by (simp add: set_rw sum.insert_remove) + also have "... = ?f 0 + ?f j" using sum0 by auto + also have "... = S $$ (0,0) * ?Q_step $$ (0, Suc i) + S $$ (0,Suc i) * ?Q_step $$ (Suc i, Suc i)" + using "2.prems" True make_mat_def by auto + also have "... = 0" by (rule make_mat_works, insert "2.prems", auto) + finally show ?thesis . + next + (*In this case, the zeroes are preserved. Each multiplication is zero.*) + case False note j_not_Suc_i = False + show ?thesis + unfolding scalar_prod_def + proof (rule sum.neutral, rule ballI) + fix x assume x: "x\{0.. x" using "2.prems" xn that by auto + moreover have "?Q_step $$ (x,j) = 0" if "x\Suc i" + using that j j_not_Suc_i unfolding make_mat_def index_mat[OF xn2 jn2] by auto + ultimately show "Matrix.row S 0 $v x * (col ?Q_step j) $v x = 0" using eq by force + qed + qed + finally show "(S * ?Q_step) $$ (0, j) = 0" . + qed + qed (auto simp add: "2.prems" i_less_n) +qed + +lemma Smith_1xn_works: + assumes A: "A \ carrier_mat 1 n" + and SQ: "(S,Q) = Smith_1xn A" +shows "is_SNF A (1\<^sub>m 1, S,Q)" +proof (cases "n=0") + case True + thus ?thesis using assms + unfolding is_SNF_def + by (auto simp add: Smith_1xn_def) +next + case False + hence n0: "0m (dim_col A))" + using SQ unfolding Smith_1xn_def by simp + have col: "dim_col A - 1 < dim_col A" using n0 A by auto + show "1\<^sub>m 1 \ carrier_mat (dim_row A) (dim_row A)" using A by auto + show Q: "Q \ carrier_mat (dim_col A) (dim_col A)" + by (rule Smith_1xn_aux_Q_carrier[OF SQ_eq], insert A, auto) + show "invertible_mat (1\<^sub>m 1)" by simp + show "invertible_mat Q" by (rule Smith_1xn_aux_invertible_Q[OF SQ_eq], insert A n0, auto) + have S_AQ: "S = A * Q" + by (rule Smith_1xn_aux_S'_AQ'[OF SQ_eq], insert A n0, auto) + thus "S = 1\<^sub>m 1 * A * Q" using A by auto + have S: "S \ carrier_mat 1 n" using S_AQ A Q by auto + show "Smith_normal_form_mat S" + proof (rule Smith_normal_form_mat_intro) + show "\a. a + 1 < min (dim_row S) (dim_col S) \ S $$ (a, a) dvd S $$ (a + 1, a + 1)" + using S by auto + have "S $$ (0, j) = 0" if j0: "0 < j" and jn: "j < n" for j + by (rule Smith_1xn_aux_S'_works[OF SQ_eq], insert A n0 j0 jn, auto) + thus "isDiagonal_mat S" unfolding isDiagonal_mat_def using S by simp + qed + qed +qed + +subsubsection \Case $n \times 1$\ + +(*The case n x 1 can be obtained from the case 1 x n taking inverses appropriately. Thus, I get + rid of the Smith_2x1 operation, since it seems to be useless.*) + +definition "Smith_nx1 A = + (let (S,P) = (Smith_1xn_aux (dim_row A - 1) (transpose_mat A) (transpose_mat A,1\<^sub>m (dim_row A))) + in (transpose_mat P, transpose_mat S))" + + +lemma Smith_nx1_works: + assumes A: "A \ carrier_mat n 1" + and SQ: "(P,S) = Smith_nx1 A" +shows "is_SNF A (P, S,1\<^sub>m 1)" +proof (cases "n=0") + case True + thus ?thesis using assms + unfolding is_SNF_def + by (auto simp add: Smith_nx1_def) +next + case False + hence n0: "0T, P\<^sup>T) = (Smith_1xn_aux (dim_row A - 1) A\<^sup>T (A\<^sup>T,1\<^sub>m (dim_row A)))" + using SQ[unfolded Smith_nx1_def] unfolding Let_def split_beta by auto + have "is_SNF (A\<^sup>T) (1\<^sub>m 1, S\<^sup>T,P\<^sup>T)" + by (rule Smith_1xn_works[unfolded Smith_1xn_def, OF _ _], insert SQ_eq A, auto) + have Pt: "P\<^sup>T \ carrier_mat (dim_col (A\<^sup>T)) (dim_col (A\<^sup>T))" + by (rule Smith_1xn_aux_Q_carrier[OF SQ_eq], insert A n0, auto) + thus P: "P \ carrier_mat (dim_row A) (dim_row A)" by auto + show "1\<^sub>m 1 \ carrier_mat (dim_col A) (dim_col A)" using A by simp + have "invertible_mat (P\<^sup>T)" + by (rule Smith_1xn_aux_invertible_Q[OF SQ_eq], insert A n0, auto) + thus "invertible_mat P" by (metis det_transpose P Pt invertible_iff_is_unit_JNF) + show "invertible_mat (1\<^sub>m 1)" by simp + have "S\<^sup>T = A\<^sup>T * P\<^sup>T" + by (rule Smith_1xn_aux_S'_AQ'[OF SQ_eq], insert A n0, auto) + hence "S = P * A" by (metis A transpose_mult transpose_transpose P carrier_matD(1)) + thus "S = P * A * 1\<^sub>m 1" using P A by auto + hence S: "S \ carrier_mat n 1" using P A by auto + have "is_SNF (A\<^sup>T) (1\<^sub>m 1, S\<^sup>T,P\<^sup>T)" + by (rule Smith_1xn_works[unfolded Smith_1xn_def, OF _ _], insert SQ_eq A, auto) + hence "Smith_normal_form_mat (S\<^sup>T)" unfolding is_SNF_def by auto + thus "Smith_normal_form_mat S" unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto + qed +qed + +subsubsection \Case $2 \times n$\ + +function Smith_2xn :: "'a mat \ ('a mat \ 'a mat \ 'a mat)" + where + "Smith_2xn A = ( + if dim_col A = 0 then (1\<^sub>m (dim_row A),A,1\<^sub>m 0) else + if dim_col A = 1 then let (P,S) = Smith_nx1 A in (P,S, 1\<^sub>m (dim_col A)) else + if dim_col A = 2 then Smith_2x2 A + else + let A1 = mat_of_cols (dim_row A) [col A 0]; + A2 = mat_of_cols (dim_row A) [col A i. i \ [1..c (P1*A2*Q1); + D = mat_of_cols (dim_row A) [col C 0, col C 1]; + E = mat_of_cols (dim_row A) [col C i. i \ [2..c (P2 * E); + k = (div_op (H $$ (0,2)) (H $$ (0,0))); + H2 = addcol (-k) 2 0 H; + (_,_,_,H2_DR) = split_block H2 1 1; + (H_1xn,Q3) = Smith_1xn H2_DR; + S = four_block_mat (Matrix.mat 1 1 (\(a,b). H$$(0,0))) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m 1 1) H_1xn; + Q1' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q1; + Q2' = four_block_mat Q2 (0\<^sub>m 2 (dim_col A - 2)) (0\<^sub>m (dim_col A - 2) 2) (1\<^sub>m (dim_col A - 2)); + Q_div_k = addrow_mat (dim_col A) (-k) 0 2; + Q3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q3 + in (P2 * P1,S,Q1' * Q2' * Q_div_k * Q3'))" + by pat_completeness auto +(*Termination is guaranteed since the algorithm is recursively applied to a + submatrix with less columns*) +termination apply (relation "measure (\A. dim_col A)") by auto + +lemma Smith_2xn_0: + assumes A: "A \ carrier_mat 2 0" + shows "is_SNF A (Smith_2xn A)" +proof - + have "Smith_2xn A = (1\<^sub>m (dim_row A),A,1\<^sub>m 0)" + using A by auto + moreover have "is_SNF A ..." by (rule is_SNF_intro, insert A, auto) + ultimately show ?thesis by simp +qed + +lemma Smith_2xn_1: + assumes A: "A \ carrier_mat 2 1" + shows "is_SNF A (Smith_2xn A)" +proof - + obtain P S where PS: "Smith_nx1 A = (P,S)" using prod.exhaust by blast + have *: "is_SNF A (P, S,1\<^sub>m 1)" by (rule Smith_nx1_works[OF A PS[symmetric]]) + moreover have "Smith_2xn A = (P,S, 1\<^sub>m (dim_col A))" + using A PS by auto + moreover have "is_SNF A ..." using * A by auto + ultimately show ?thesis by simp +qed + +lemma Smith_2xn_2: + assumes A: "A \ carrier_mat 2 2" + shows "is_SNF A (Smith_2xn A)" +proof - + have "Smith_2xn A = Smith_2x2 A" using A by auto + from this show ?thesis using SNF_2x2_works using A by auto +qed + +lemma is_SNF_Smith_2xn_n_ge_2: + assumes A: "A \ carrier_mat 2 n" and n: "n>2" + shows "is_SNF A (Smith_2xn A)" + using A n id +proof (induct A arbitrary: n rule: Smith_2xn.induct) + case (1 A) + note A = "1.prems"(1) + note n_ge_2 = "1.prems"(2) + have dim_col_A_g2: "dim_col A > 2" using n_ge_2 A by auto + define A1 where "A1 = mat_of_cols (dim_row A) [col A 0]" + define A2 where "A2 = mat_of_cols (dim_row A) [col A i. i \ [1..c (P1*A2*Q1)" + define D where "D = mat_of_cols (dim_row A) [col C 0, col C 1]" + define E where "E = mat_of_cols (dim_row A) [col C i. i \ [2..c (P2 * E)" + define k where "k = div_op (H $$ (0,2)) (H $$ (0,0))" + define H2 where "H2 = addcol (-k) 2 0 H" + obtain H2_UL H2_UR H2_DL H2_DR + where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = (split_block H2 1 1)" by (metis prod_cases4) + obtain H_1xn Q3 where H_1xn_Q3: "(H_1xn,Q3) = Smith_1xn H2_DR" by (metis surj_pair) + define S where "S = four_block_mat (Matrix.mat 1 1 (\(a,b). H$$(0,0))) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m 1 1) H_1xn" + define Q1' where "Q1' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q1" + define Q2' where "Q2' = four_block_mat Q2 (0\<^sub>m 2 (dim_col A - 2)) (0\<^sub>m (dim_col A - 2) 2) (1\<^sub>m (dim_col A - 2))" + define Q_div_k where "Q_div_k = addrow_mat (dim_col A) (-k) 0 2" + define Q3' where "Q3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q3" + have Smith_2xn_rw: "Smith_2xn A = (P2 * P1, S, Q1' * Q2' * Q_div_k * Q3')" + proof (rule prod3_intro) + have P1_def: "fst (Smith_2xn A2) = P1" and Q1_def: "snd (snd (Smith_2xn A2)) = Q1" + and P2_def: "fst (Smith_2x2 D) = P2" and Q2_def: "snd (snd (Smith_2x2 D)) = Q2" + and H_1xn_def: "fst (Smith_1xn H2_DR) = H_1xn" and Q3_def: "snd (Smith_1xn H2_DR) = Q3" + and H2_DR_def: "snd (snd (snd (split_block H2 1 1))) = H2_DR" + using P2D2Q2 P1D1Q1 H_1xn_Q3 split_H2 fstI sndI by metis+ + note aux= P1_def Q1_def Q1'_def Q2'_def Q_div_k_def Q3'_def S_def A1_def[symmetric] + C_def[symmetric] P2_def Q2_def Q3_def D_def[symmetric] E_def[symmetric] H_def[symmetric] + k_def[symmetric] H2_def[symmetric] H2_DR_def H_1xn_def A2_def[symmetric] + show "fst (Smith_2xn A) = P2 * P1" + using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta + by (insert P1D1Q1 P2D2Q2 D_def C_def, unfold aux, auto simp del: Smith_2xn.simps) + show "fst (snd (Smith_2xn A)) = S" + using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta + by (insert P1D1Q1 P2D2Q2, unfold aux, auto simp del: Smith_2xn.simps) + show "snd (snd (Smith_2xn A)) = Q1' * Q2' * Q_div_k * Q3'" + using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta + by (insert P1D1Q1 P2D2Q2, unfold aux, auto simp del: Smith_2xn.simps) + qed + show ?case + proof (unfold Smith_2xn_rw, rule is_SNF_intro) + have is_SNF_A2: "is_SNF A2 (Smith_2xn A2)" + proof (cases "2carrier_mat 2 2" unfolding A2_def using A by auto + hence *: "Smith_2xn A2 = Smith_2x2 A2" by auto + show ?thesis unfolding * using SNF_2x2_works A2 by auto + qed + have A1[simp]: "A1 \ carrier_mat (dim_row A) 1" unfolding A1_def by auto + have A2[simp]: "A2 \ carrier_mat (dim_row A) (dim_col A - 1)" unfolding A2_def by auto + have P1[simp]: "P1 \ carrier_mat (dim_row A) (dim_row A)" + and inv_P1: "invertible_mat P1" + and Q1: "Q1 \ carrier_mat (dim_col A2) (dim_col A2)" and inv_Q1: "invertible_mat Q1" + and SNF_P1A2Q1: "Smith_normal_form_mat (P1*A2*Q1)" + using is_SNF_A2 P1D1Q1 A2 unfolding is_SNF_def by fastforce+ + have D[simp]: "D \ carrier_mat 2 2" unfolding D_def + by (metis "1"(2) One_nat_def Suc_eq_plus1 carrier_matD(1) list.size(3) + list.size(4) mat_of_cols_carrier(1) numerals(2)) + have is_SNF_D: "is_SNF D (Smith_2x2 D)" using SNF_2x2_works D by auto + hence P2[simp]: "P2 \ carrier_mat (dim_row A) (dim_row A)" and inv_P2: "invertible_mat P2" + and Q2[simp]: "Q2 \ carrier_mat (dim_col D) (dim_col D)" and inv_Q2: "invertible_mat Q2" + using P2D2Q2 D_def unfolding is_SNF_def by force+ + show P2_P1: "P2 * P1 \ carrier_mat (dim_row A) (dim_row A)" by (rule mult_carrier_mat[OF P2 P1]) + show "invertible_mat (P2 * P1)" by (rule invertible_mult_JNF[OF P2 P1 inv_P2 inv_P1]) + have Q1': "Q1' \ carrier_mat (dim_col A) (dim_col A)" using Q1 unfolding Q1'_def + by (auto, smt A2 One_nat_def add_diff_inverse_nat carrier_matD(1) carrier_matD(2) carrier_matI + dim_col_A_g2 gr_implies_not0 index_mat_four_block(2) index_mat_four_block(3) + index_one_mat(2) index_one_mat(3) less_Suc0) + have Q2': "Q2' \ carrier_mat (dim_col A) (dim_col A)" using Q2 unfolding Q2'_def + by (smt D One_nat_def Suc_lessD add_diff_inverse_nat carrier_matD(1) carrier_matD(2) + carrier_matI dim_col_A_g2 gr_implies_not0 index_mat_four_block(2) index_mat_four_block(3) + index_one_mat(2) index_one_mat(3) less_2_cases numeral_2_eq_2 semiring_norm(138)) + have H2[simp]: "H2 \ carrier_mat (dim_row A) (dim_col A)" using A P2 D unfolding H2_def H_def + by (smt E_def Q2 Q2' Q2'_def append_cols_def arithmetic_simps(50) carrier_matD(1) carrier_matD(2) + carrier_mat_triv index_mat_addcol(4) index_mat_addcol(5) index_mat_four_block(2) + index_mat_four_block(3) index_mult_mat(2) index_mult_mat(3) index_one_mat(2) index_zero_mat(2) + index_zero_mat(3) length_map length_upt mat_of_cols_carrier(3)) + have H'[simp]: "H2_DR \ carrier_mat 1 (n - 1)" + by (rule split_block(4)[OF split_H2[symmetric]], insert H2 A n_ge_2, auto) + have is_SNF_H': "is_SNF H2_DR (1\<^sub>m 1, H_1xn, Q3)" + by (rule Smith_1xn_works[OF H' H_1xn_Q3]) + from this have Q3: "Q3 \ carrier_mat (dim_col H2_DR) (dim_col H2_DR)" and inv_Q3: "invertible_mat Q3" + unfolding is_SNF_def by auto + have Q3': "Q3' \ carrier_mat (dim_col A) (dim_col A)" + by (metis A A2 H' Q1 Q1' Q1'_def Q3 Q3'_def carrier_matD(1) carrier_matD(2) carrier_matI + index_mat_four_block(2) index_mat_four_block(3)) + have Q_div_k[simp]: "Q_div_k \ carrier_mat (dim_col A) (dim_col A)" unfolding Q_div_k_def by auto + have inv_Q_div_k: "invertible_mat Q_div_k" + by (metis Q_div_k Q_div_k_def det_addrow_mat det_one invertible_iff_is_unit_JNF + invertible_mat_one nat.simps(3) numerals(2) one_carrier_mat) + show "Q1' * Q2' * Q_div_k * Q3' \ carrier_mat (dim_col A) (dim_col A)" + using Q1' Q2' Q_div_k Q3' by auto + have inv_Q1': "invertible_mat Q1'" + proof - + have "invertible_mat (four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (n - 1)) (0\<^sub>m (n - 1) 1) Q1)" + by (rule invertible_mat_four_block_mat_lower_right, insert Q1 inv_Q1 A2 "1.prems", auto) + thus ?thesis unfolding Q1'_def using A by auto + qed + have inv_Q2': "invertible_mat Q2'" + by (unfold Q2'_def, rule invertible_mat_four_block_mat_lower_right_id, + insert Q2 n_ge_2 inv_Q2 A D, auto) + have inv_Q3': "invertible_mat Q3'" + proof - + have "invertible_mat (four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (n - 1)) (0\<^sub>m (n - 1) 1) Q3)" + by (rule invertible_mat_four_block_mat_lower_right, insert Q3 H' inv_Q3 "1.prems", auto) + thus ?thesis unfolding Q3'_def using A by auto + qed + show "invertible_mat (Q1' * Q2' * Q_div_k * Q3')" + using inv_Q1' inv_Q2' inv_Q_div_k inv_Q3' + by (meson Q1' Q2' Q3' Q_div_k invertible_mult_JNF mult_carrier_mat) + have A_A1_A2: "A = A1 @\<^sub>c A2" unfolding A1_def A2_def append_cols_def + proof (rule eq_matI, auto) + fix i assume i: "i < dim_row A" show 1: "A $$ (i, 0) = mat_of_cols (dim_row A) [col A 0] $$ (i, 0)" + by (metis dim_col_A_g2 gr_zeroI i index_col mat_of_cols_Cons_index_0 not_less0) + let ?xs = "(map (col A) [Suc 0..c A2) = ((P1 * A1) @\<^sub>c (P1 * A2))" + by (rule append_cols_mult_left, insert A1 A2 P1, auto) + have "P1 * A * Q1' = P1 * (A1 @\<^sub>c A2) * Q1'" using A_A1_A2 by simp + also have "... = ((P1 * A1) @\<^sub>c (P1 * A2)) * Q1'" unfolding aux .. + also have "... = (P1 * A1) @\<^sub>c ((P1 * A2) * Q1)" + by (rule append_cols_mult_right_id, insert P1 A1 A2 Q1'_def Q1, auto) + finally show ?thesis unfolding C_def by auto + qed + have E_ij_0: "E $$ (i,j) = 0" if i: "i (1,0)" + for i j + proof - + let ?ws = "(map (col C) [2..c E" + proof (rule eq_matI) + have "C $$ (i, j) = mat_of_cols (dim_row A) [col C 0, col C 1] $$ (i, j)" + if i: "i < dim_row A" and j: "j < 2" for i j + proof - + let ?ws = "[col C 0, col C 1]" + have "mat_of_cols (dim_row A) [col C 0, col C 1] $$ (i, j) = ?ws ! j $v i" + by (rule mat_of_cols_index, insert i j, auto) + also have "... = C $$ (i, j)" using j index_col + by (auto, smt A C_P1_A_Q1' P1 Q1' Suc_lessD carrier_matD i index_col index_mult_mat(2,3) + less_2_cases n_ge_2 nth_Cons_0 nth_Cons_Suc numeral_2_eq_2) + finally show ?thesis by simp + qed + moreover have "C $$ (i, j) = mat_of_cols (dim_row A) (map (col C) [2.. 2" for i j + proof - + let ?ws = "(map (col C) [2..i j. i < dim_row (D @\<^sub>c E) \ j < dim_col (D @\<^sub>c E) \ C $$ (i, j) = (D @\<^sub>c E) $$ (i, j)" + unfolding D_def E_def append_cols_def by (auto simp add: numerals) + show "dim_row C = dim_row (D @\<^sub>c E)" using P1 A unfolding C_def D_def E_def append_cols_def by auto + show "dim_col C = dim_col (D @\<^sub>c E)" using A1 Q1 A2 A n_ge_2 + unfolding C_def D_def E_def append_cols_def by auto + qed + have E[simp]: "E\carrier_mat 2 (n-2)" unfolding E_def using A by auto + have H[simp]: "H \ carrier_mat (dim_row A) (dim_col A)" unfolding H_def append_cols_def using A + by (smt E Groups.add_ac(1) One_nat_def P2_P1 Q2 Q2' Q2'_def carrier_matD index_mat_four_block + plus_1_eq_Suc index_mult_mat index_one_mat index_zero_mat numeral_2_eq_2 carrier_matI) + have H_P2_P1_A_Q1'_Q2': "H = P2 * P1 * A * Q1' * Q2'" + proof - + have aux: "(P2 * D @\<^sub>c P2 * E) = P2 * (D @\<^sub>c E)" + by (rule append_cols_mult_left[symmetric], insert D E P2 A, auto simp add: D_def E_def) + have "H = P2 * D * Q2 @\<^sub>c P2 * E" using H_def by auto + also have "... = (P2 * D @\<^sub>c P2 * E) * Q2'" by (rule append_cols_mult_right_id2[symmetric], + insert Q2 D Q2'_def, auto simp add: D_def E_def) + also have "... = (P2 * (D @\<^sub>c E)) * Q2'" using aux by auto + also have "... = P2 * C * Q2'" unfolding C_D_E by auto + also have "... = P2 * P1 * A * Q1' * Q2'" unfolding C_P1_A_Q1' + by (smt P1 P2 Q1' P2_P1 assoc_mult_mat carrier_mat_triv index_mult_mat(2)) + finally show ?thesis . + qed + have H2_H_Q_div_k: "H2 = H * Q_div_k" unfolding H2_def Q_div_k_def + by (metis H_P2_P1_A_Q1'_Q2' Q2' addcol_mat carrier_matD(2) dim_col_A_g2 gr_implies_not0 + mat_carrier times_mat_def zero_order(5)) + hence H2_P2_P1_A_Q1'_Q2'_Q_div_k: "H2 = P2 * P1 * A * Q1' * Q2' * Q_div_k" + unfolding H_P2_P1_A_Q1'_Q2' by simp + have H2_as_four_block_mat: "H2 = four_block_mat H2_UL H2_UR H2_DL H2_DR" + by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto) + have H2_UL: "H2_UL \ carrier_mat 1 1" + by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto) + have H2_UR: "H2_UR \ carrier_mat 1 (dim_col A - 1)" + by (rule split_block(2)[OF split_H2[symmetric]], insert H2 A n_ge_2, auto) + have H2_DL: "H2_DL \ carrier_mat 1 1" + by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto) + have H2_DR: "H2_DR \ carrier_mat 1 (dim_col A - 1)" + by (rule split_block[OF split_H2[symmetric]], insert H2 A n_ge_2, auto) + have H2_UR_00: "H2_UR $$ (0,0) = 0" + proof - + have "H2_UR $$ (0,0) = H2 $$ (0,1)" + by (smt A H2_H_Q_div_k H2_UL H2_as_four_block_mat H2_def H_P2_P1_A_Q1'_Q2' + Num.numeral_nat(7) P2_P1 Q2' add_diff_cancel_left' carrier_matD dim_col_A_g2 index_mat_addcol + index_mat_four_block index_mult_mat less_trans_Suc plus_1_eq_Suc pos2 semiring_norm(138) + zero_less_one_class.zero_less_one) + also have "... = H $$ (0,1)" + unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto) + also have "... = (P2 * D * Q2) $$ (0,1)" + by (smt C_D_E C_P1_A_Q1' D H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' H_def Q1' + Q2 add_lessD1 append_cols_def carrier_matD(1) carrier_matD(2) dim_col_A_g2 + index_mat_four_block index_mult_mat(2) index_mult_mat(3) lessI numerals(2) plus_1_eq_Suc zero_less_Suc) + also have "... = 0" using is_SNF_D P2D2Q2 D + unfolding is_SNF_def Smith_normal_form_mat_def isDiagonal_mat_def by auto + finally show "H2_UR $$ (0,0) = 0" . + qed + have H2_UR_0j: "H2_UR $$ (0,j) = 0" if j_ge_1: "j > 1" and j: "jv 2" + by (rule eq_vecI, unfold col_def, insert E E_ij_0 j j_ge_1 n_ge_2, auto) + (metis E Suc_diff_Suc Suc_lessD Suc_less_eq Suc_pred carrier_matD index_vec numerals(2), insert E, blast) + have "H2_UR $$ (0,j) = H2 $$ (0,j+1)" + by (metis (no_types, lifting) A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_UL H2_as_four_block_mat H2_def + H_P2_P1_A_Q1'_Q2' P2_P1 Q2' add_diff_cancel_right' carrier_matD index_mat_addcol(5) + index_mat_four_block index_mult_mat(2,3) less_diff_conv less_numeral_extra(1) not_add_less2 pos2 j) + also have "... = H $$ (0,j+1)" unfolding H2_def + by (metis A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_def H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 Q_div_k_def + add_right_cancel carrier_matD(1) carrier_matD(2) index_mat_addcol(3) index_mat_addcol(5) + index_mat_addrow_mat(3) index_mult_mat(2) index_mult_mat(3) less_diff_conv less_not_refl2 + numerals(2) plus_1_eq_Suc pos2 j j_ge_1) + also have "... = (if j+1 < dim_col (P2 * D * Q2) + then (P2 * D * Q2) $$ (0, j+1) else (P2*E) $$ (0, (j+1) - 2))" + by (unfold H_def, rule append_cols_nth, insert E P2 A Q2 D j, auto simp add: E_def) + also have "... = (P2*E) $$ (0, j - 1)" + by (metis (no_types, lifting) D One_nat_def Q2 add_Suc_right add_lessD1 arithmetic_simps(50) + carrier_matD(2) diff_Suc_Suc index_mult_mat(3) not_less_eq numeral_2_eq_2 j_ge_1) + also have "... = Matrix.row P2 0 \ col E (j - 1)" + by (rule index_mult_mat, insert P2 j_ge_1 A j, auto simp add: E_def) + also have "... = 0" unfolding col_E_0 by (simp add: scalar_prod_def) + finally show ?thesis . + qed + have H00_dvd_D01: "H$$(0,0) dvd D$$(0,1)" + proof - + have "H$$(0,0) = (P2*D*Q2) $$ (0,0)" unfolding H_def using append_cols_nth D E + by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' + One_nat_def P1 Q1' Q2 Suc_lessD append_cols_def carrier_matD dim_col_A_g2 + index_mat_four_block index_mult_mat numerals(2) plus_1_eq_Suc zero_less_Suc) + also have "... dvd D$$(0,1)" by (rule S00_dvd_all_A[OF D _ _ inv_P2 inv_Q2], + insert is_SNF_D P2D2Q2 P2 Q2 D, unfold is_SNF_def, auto) + finally show ?thesis . + qed + have D01_dvd_H02: "D$$(0,1) dvd H$$(0,2)" and D01_dvd_H12: "D$$(0,1) dvd H$$(1,2)" + proof - + have "D$$(0,1) = C$$(0,1)" unfolding C_D_E + by (smt A C_D_E C_P1_A_Q1' D One_nat_def P1 Q1' append_cols_def carrier_matD(1) carrier_matD(2) + dim_col_A_g2 index_mat_four_block(1) index_mat_four_block(2) index_mat_four_block(3) + index_mult_mat(2) index_mult_mat(3) lessI less_trans_Suc numerals(2) pos2) + also have "... = (P1*A2*Q1) $$ (0,0)" using C_def + by (smt "1"(2) A1 A_A1_A2 P1 Q1 add_diff_cancel_left' append_cols_def card_num_simps(30) + carrier_matD dim_col_A_g2 index_mat_four_block index_mult_mat less_numeral_extra(4) + less_trans_Suc plus_1_eq_Suc pos2) + also have "... dvd (P1*A2*Q1) $$ (1,1)" + by (smt "1"(2) A2 One_nat_def P1 Q1 S00_dvd_all_A SNF_P1A2Q1 carrier_matD(1) carrier_matD(2) dim_col_A_g2 + dvd_elements_mult_matrix_left_right inv_P1 inv_Q1 lessI less_diff_conv numeral_2_eq_2 plus_1_eq_Suc) + also have "... = C $$ (1,2)" unfolding C_def + by (smt "1"(2) A1 A_A1_A2 One_nat_def P1 Q1 append_cols_def carrier_matD(1) carrier_matD(2) diff_Suc_1 + dim_col_A_g2 index_mat_four_block index_mult_mat lessI not_numeral_less_one numeral_2_eq_2) + also have "... = E $$ (1,0)" unfolding C_D_E + by (smt "1"(3) A C_D_E C_P1_A_Q1' D One_nat_def append_cols_def carrier_matD less_irrefl_nat + P1 Q1' diff_Suc_1 diff_Suc_Suc index_mat_four_block index_mult_mat lessI numerals(2)) + finally have *: "D$$(0,1) dvd E $$(1,0)" by auto + also have "... dvd (P2*E)$$ (0,0)" + by (smt "1"(3) A E E_ij_0 P2 carrier_matD(1) carrier_matD(2) dvd_0_right + dvd_elements_mult_matrix_left dvd_refl pos2 zero_less_diff) + also have "... = H$$(0,2)" unfolding H_def + by (smt "1"(3) A C_D_E C_P1_A_Q1' D Groups.add_ac(1) H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat + H_P2_P1_A_Q1'_Q2' One_nat_def P1 Q1' Q2 add_diff_cancel_left' append_cols_def carrier_matD + index_mat_four_block index_mult_mat less_irrefl_nat numerals(2) plus_1_eq_Suc pos2) + finally show "D $$ (0, 1) dvd H $$ (0, 2)" . + have "E $$(1,0) dvd (P2*E)$$ (1,0)" + by (smt "1"(3) A E E_ij_0 P2 carrier_matD(1) carrier_matD(2) dvd_0_right + dvd_elements_mult_matrix_left dvd_refl rel_simps(49) semiring_norm(76) zero_less_diff) + also have "... = H $$(1,2)" unfolding H_def + by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' + One_nat_def P1 Q1' Q2 add_diff_cancel_left' append_cols_def carrier_matD diff_Suc_eq_diff_pred + index_mat_four_block index_mult_mat lessI less_irrefl_nat n_ge_2 numerals(2) plus_1_eq_Suc) + finally show "D$$(0,1) dvd H$$(1,2)" using * by auto + qed + have kH00_eq_H02: "k * H $$ (0, 0) = H $$ (0, 2)" + using id D01_dvd_H02 H00_dvd_D01 unfolding k_def is_div_op_def by auto + have H2_UR_01: "H2_UR $$ (0,1) = 0" + proof - + have "H2_UR $$ (0,1) = H2 $$ (0,2)" + by (metis (no_types, lifting) A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_UL H2_as_four_block_mat One_nat_def + P2_P1 Q_div_k_def carrier_matD diff_Suc_1 dim_col_A_g2 index_mat_addrow_mat(3) + index_mat_four_block index_mult_mat(2,3) numeral_2_eq_2 pos2 rel_simps(50) rel_simps(68)) + also have "... = (-k) * H $$ (0, 0) + H $$ (0, 2)" + by (unfold H2_def, rule index_mat_addcol[of _ ], insert H A n_ge_2, auto) + also have "... = 0" using kH00_eq_H02 by auto + finally show ?thesis . + qed + have H2_UR_0: "H2_UR = (0\<^sub>m 1 (n - 1))" + by (rule eq_matI, insert H2_UR_0j H2_UR_01 H2_UR_00 H2_UR A nat_neq_iff, auto) + have H2_UL_H: "H2_UL $$ (0,0) = H $$ (0,0)" + proof - + have "H2_UL $$ (0,0) = H2 $$ (0,0)" + by (metis (no_types, lifting) Pair_inject index_mat(1) split_H2 split_block_def + zero_less_one_class.zero_less_one) + also have "... = H $$ (0,0)" + unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto) + finally show ?thesis . + qed + have H2_DL_H_10: "H2_DL $$ (0,0) = H$$(1,0)" + proof - + have "H2_DL $$ (0,0) = H2 $$ (1,0)" + by (smt H2_DL One_nat_def Pair_inject add.right_neutral add_Suc_right carrier_matD(1) + dim_row_mat(1) index_mat(1) rel_simps(68) split_H2 split_block_def split_conv) + also have "... = H$$(1,0)" unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto) + finally show ?thesis . + qed + have H_10: "H $$(1,0) = 0" + proof - + have "H $$(1,0) = (P2 * D * Q2) $$ (1,0)" unfolding H_def + by (smt A C_D_E C_P1_A_Q1' D E One_nat_def P1 P2_P1 Q2 Q2' Q2'_def Suc_lessD append_cols_def + carrier_matD dim_col_A_g2 index_mat_four_block index_mult_mat index_one_mat + index_zero_mat lessI numerals(2)) + also have "... = 0" using is_SNF_D P2D2Q2 D + unfolding is_SNF_def Smith_normal_form_mat_def isDiagonal_mat_def by auto + finally show ?thesis . + qed + have S_H2_Q3': "S = H2 * Q3'" + and S_as_four_block_mat: "S = four_block_mat (H2_UL) (0\<^sub>m 1 (n - 1)) (H2_DL) (H2_DR * Q3)" + proof - + have "H2 * Q3' = four_block_mat (H2_UL * 1\<^sub>m 1 + H2_UR * 0\<^sub>m (dim_col A - 1) 1) + (H2_UL * 0\<^sub>m 1 (dim_col A - 1) + H2_UR * Q3) + (H2_DL * 1\<^sub>m 1 + H2_DR * 0\<^sub>m (dim_col A - 1) 1) (H2_DL * 0\<^sub>m 1 (dim_col A - 1) + H2_DR * Q3)" + unfolding H2_as_four_block_mat Q3'_def + by (rule mult_four_block_mat[OF H2_UL H2_UR H2_DL H2_DR], insert Q3 A H', auto) + also have "... = four_block_mat (H2_UL) (0\<^sub>m 1 (n - 1)) (H2_DL) (H2_DR * Q3)" + by (rule cong_four_block_mat, insert H2_UR_0 H2_UL H2_UR H2_DL H2_DR Q3, auto) + also have *: "... = S" unfolding S_def + proof (rule cong_four_block_mat) + show "H2_UL = Matrix.mat 1 1 (\(a, b). H $$ (0, 0))" + by (rule eq_matI, insert H2_UL H2_UL_H, auto) + show "H2_DR * Q3 = H_1xn" using is_SNF_H' unfolding is_SNF_def by auto + show "0\<^sub>m 1 (n - 1) = 0\<^sub>m 1 (dim_col A - 1)" using A by auto + show "H2_DL = 0\<^sub>m 1 1" using H2_DL H2_DL_H_10 H_10 by auto + qed + finally show "S = H2 * Q3'" + and "S = four_block_mat (H2_UL) (0\<^sub>m 1 (n - 1)) (H2_DL) (H2_DR * Q3)" + using * by auto + qed + thus "S = P2 * P1 * A * (Q1' * Q2' * Q_div_k * Q3')" unfolding H2_P2_P1_A_Q1'_Q2'_Q_div_k + by (smt Q1' Q2' Q2'_def Q3' Q3'_def Q_div_k assoc_mult_mat + carrier_matD carrier_mat_triv index_mult_mat) + show "Smith_normal_form_mat S" + proof (rule Smith_normal_form_mat_intro) + have Sij_0: "S$$(i,j) = 0" if ij: "i \ j" and i: "i < dim_row S" and j: "j < dim_col S" for i j + proof (cases "i=1 \ j=0") + case True + have "S$$(1,0) = 0" using S_as_four_block_mat + by (metis (no_types, lifting) H2_DL_H_10 H2_UL H_10 One_nat_def True carrier_matD diff_Suc_1 + index_mat_four_block rel_simps(71) that(2) that(3) zero_less_one_class.zero_less_one) + then show ?thesis using True by auto + next + case False note not_10 = False + show ?thesis + proof (cases "i=0") + case True + hence j0: "j>0" using ij by auto + then show ?thesis using S_as_four_block_mat + by (smt "1"(2) H2_DR H2_H_Q_div_k H2_UL H_P2_P1_A_Q1'_Q2' Num.numeral_nat(7) P2_P1 Q3 S_H2_Q3' + Suc_pred True carrier_matD index_mat_four_block index_mult_mat index_zero_mat(1) + not_less_eq plus_1_eq_Suc pos2 that(3) zero_less_one_class.zero_less_one) + next + case False + have SNF_H_1xn: "Smith_normal_form_mat H_1xn" using is_SNF_H' unfolding is_SNF_def by auto + have i1: "i=1" using False ij i H2_DR H2_UL S_as_four_block_mat by auto + hence j1: "j>1" using ij not_10 by auto thm is_SNF_H' + have "S$$(i,j) = (if i < dim_row H2_UL then if j < dim_col H2_UL then H2_UL $$ (i, j) + else (0\<^sub>m 1 (n - 1)) $$ (i, j - dim_col H2_UL) + else if j < dim_col H2_UL then H2_DL $$ (i - dim_row H2_UL, j) + else (H2_DR * Q3) $$ (i - dim_row H2_UL, j - dim_col H2_UL))" + unfolding S_as_four_block_mat + by (rule index_mat_four_block, insert i j H2_UL H2_DR Q3 S_H2_Q3' H2 Q3' A, auto) + also have "... = (H2_DR * Q3) $$ (0, j - 1)" using H2_UL i1 not_10 by auto + also have "... = H_1xn $$ (0,j-1)" + using S_def calculation i1 j not_10 i by auto + also have "... = 0" using SNF_H_1xn j1 i j + unfolding Smith_normal_form_mat_def isDiagonal_mat_def + by (simp add: S_def i1) + finally show ?thesis . + qed + qed + thus "isDiagonal_mat S" unfolding isDiagonal_mat_def by auto + have "S$$(0,0) dvd S$$(1,1)" + proof - + have dvd_all: "\i j. i < 2 \ j < n \ H2_UL$$(0,0) dvd (H2 * Q3') $$ (i, j)" + proof (rule dvd_elements_mult_matrix_right) + show H2': "H2 \ carrier_mat 2 n" using H2 A by auto + show "Q3' \ carrier_mat n n" using Q3' A by auto + have "H2_UL $$ (0, 0) dvd H2 $$ (i, j)" if i: "i < 2" and j: "j < n" for i j + proof (cases "i=0") + case True + then show ?thesis + by (metis (no_types, lifting) A H2_H_Q_div_k H2_UL H2_UR_0 H2_as_four_block_mat + H_P2_P1_A_Q1'_Q2' P2_P1 Q3 Q_div_k S_as_four_block_mat Sij_0 carrier_matD + dvd_0_right dvd_refl index_mat_four_block index_mult_mat(2,3) j less_one pos2) + next + case False + hence i1: "i=1" using i by auto + have H2_10_0: "H2 $$ (1,0) = 0" + by (metis (no_types, lifting) H2_H_Q_div_k H2_def H_10 H_P2_P1_A_Q1'_Q2' One_nat_def + Q2' H2' basic_trans_rules(19) carrier_matD dim_col_A_g2 index_mat_addcol(3) + index_mult_mat(2,3) lessI numeral_2_eq_2 rel_simps(76)) + moreover have H2_UL00_dvd_H211:"H2_UL $$ (0, 0) dvd H2 $$ (1, 1)" + proof - + have "H2_UL $$ (0, 0) = H $$ (0, 0)" by (simp add: H2_UL_H) + also have "... = (P2*D*Q2) $$ (0,0)" unfolding H_def using append_cols_nth D E + by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat + H_P2_P1_A_Q1'_Q2' One_nat_def P1 Q1' Q2 Suc_lessD append_cols_def carrier_matD + dim_col_A_g2 index_mat_four_block index_mult_mat numerals(2) plus_1_eq_Suc zero_less_Suc) + also have "... dvd (P2*D*Q2) $$ (1,1)" + using is_SNF_D P2D2Q2 unfolding is_SNF_def Smith_normal_form_mat_def by auto + (metis D Q2 carrier_matD index_mult_mat(1) index_mult_mat(2) lessI numerals(2) pos2) + also have "... = H $$ (1,1)" unfolding H_def using append_cols_nth D E + by (smt A C_D_E C_P1_A_Q1' H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' + One_nat_def P1 Q1' Q2 append_cols_def carrier_matD(1) carrier_matD(2) dim_col_A_g2 + index_mat_four_block index_mult_mat(2) index_mult_mat(3) lessI less_trans_Suc + numerals(2) plus_1_eq_Suc pos2) + also have "... = H2 $$ (1, 1)" + by (metis A H2_def H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 Q2' carrier_matD dim_col_A_g2 i i1 + index_mat_addcol(3) index_mult_mat(2) index_mult_mat(3) less_trans_Suc nat_neq_iff pos2) + finally show ?thesis . + qed + moreover have H2_UL00_dvd_H212: "H2_UL $$ (0, 0) dvd H2 $$ (1, 2)" + proof - + have "H2_UL $$ (0, 0) = H $$ (0, 0)" by (simp add: H2_UL_H) + also have "... dvd H $$ (1,2)" using D01_dvd_H12 H00_dvd_D01 dvd_trans by blast + also have "... = (-k) * H $$ (1,0) + H $$ (1,2)" + using H_10 by auto + also have "... = H2 $$ (1,2)" + unfolding H2_def by (rule index_mat_addcol[symmetric], insert H A n_ge_2, auto) + finally show ?thesis . + qed + moreover have "H2 $$ (1, j) = 0" if j1: "j>2" and j: "jia = 0..<2. Matrix.row P2 1 $v ia * col E (j-2) $v ia)" + using E A E_def j j1 by auto + also have "... = (\ia \ {0,1}. Matrix.row P2 1 $v ia * col E (j-2) $v ia)" + by (rule sum.cong, auto) + also have "... = Matrix.row P2 1 $v 0 * col E (j - 2) $v 0 + + Matrix.row P2 1 $v 1 * col E (j - 2) $v 1" + by (simp add: sum_two_elements[OF zero_neq_one]) + also have "... = 0" using E_ij_0 E_def E A + by (auto, smt D Q2 Q2' Q2'_def Suc_lessD add_cancel_right_right add_diff_inverse_nat + arith_extra_simps(19) carrier_matD i i1 index_col index_mat_four_block(3) + index_one_mat(3) less_2_cases nat_add_left_cancel_less numeral_2_eq_2 + semiring_norm(138) semiring_norm(160) j j1 zero_less_diff) + finally show ?thesis . + qed + ultimately show ?thesis using i1 False + by (metis One_nat_def dvd_0_right less_2_cases nat_neq_iff j) + qed + thus "\i j. i < 2 \ j < n \ H2_UL $$ (0, 0) dvd H2 $$ (i, j)" by auto + qed + have "S$$(0,0) = H2_UL $$ (0,0)" using H2_UL S_as_four_block_mat by auto + also have "... dvd (H2*Q3') $$ (1,1)" using dvd_all n_ge_2 by auto + also have "... = S $$ (1,1)" using S_H2_Q3' by auto + finally show ?thesis . + qed + thus "\a. a + 1 < min (dim_row S) (dim_col S) \ S $$ (a, a) dvd S $$ (a + 1, a + 1)" + by (metis "1"(2) H2_H_Q_div_k H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 S_H2_Q3' Suc_eq_plus1 + index_mult_mat(2) less_Suc_eq less_one min_less_iff_conj numeral_2_eq_2 carrier_matD(1)) + qed + qed +qed + + +lemma is_SNF_Smith_2xn: + assumes A: "A \ carrier_mat 2 n" + shows "is_SNF A (Smith_2xn A)" +proof (cases "n>2") + case True + then show ?thesis using is_SNF_Smith_2xn_n_ge_2[OF A] by simp +next + case False + hence "n=0 \ n=1 \ n=2" by auto + then show ?thesis using Smith_2xn_0 Smith_2xn_1 Smith_2xn_2 A by blast +qed + +subsubsection \Case $n \times 2$\ + +definition "Smith_nx2 A = (let (P,S,Q) = Smith_2xn A\<^sup>T in + (Q\<^sup>T, S\<^sup>T, P\<^sup>T))" + +lemma is_SNF_Smith_nx2: + assumes A: "A \ carrier_mat n 2" + shows "is_SNF A (Smith_nx2 A)" +proof - + obtain P S Q where PSQ: "(P,S,Q) = Smith_2xn A\<^sup>T" by (metis prod_cases3) + hence rw: "Smith_nx2 A = (Q\<^sup>T, S\<^sup>T, P\<^sup>T)" unfolding Smith_nx2_def by (metis split_conv) + have "is_SNF A\<^sup>T (Smith_2xn A\<^sup>T)" by (rule is_SNF_Smith_2xn, insert id A, auto) + hence is_SNF_PSQ: "is_SNF A\<^sup>T (P,S,Q)" using PSQ by auto + show ?thesis + proof (unfold rw, rule is_SNF_intro) + show Qt: "Q\<^sup>T \ carrier_mat (dim_row A) (dim_row A)" + and Pt: "P\<^sup>T \ carrier_mat (dim_col A) (dim_col A)" + and "invertible_mat Q\<^sup>T" and "invertible_mat P\<^sup>T" + using is_SNF_PSQ invertible_mat_transpose unfolding is_SNF_def by auto + have "Smith_normal_form_mat S" and PATQ: "S = P * A\<^sup>T * Q" + using is_SNF_PSQ invertible_mat_transpose unfolding is_SNF_def by auto + thus "Smith_normal_form_mat S\<^sup>T" unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto + show "S\<^sup>T = Q\<^sup>T * A * P\<^sup>T" using PATQ + by (smt Matrix.transpose_mult Matrix.transpose_transpose Pt Qt assoc_mult_mat + carrier_mat_triv index_mult_mat(2)) + qed +qed + +subsubsection \Case $m \times n$\ + +(*This is necessary to avoid a loop with domintros*) +declare Smith_2xn.simps[simp del] + +function (domintros) Smith_mxn :: "'a mat \ ('a mat \ 'a mat \ 'a mat)" + where + "Smith_mxn A = ( + if dim_row A = 0 \ dim_col A = 0 then (1\<^sub>m (dim_row A),A,1\<^sub>m (dim_col A)) + else if dim_row A = 1 then (1\<^sub>m 1, Smith_1xn A) + else if dim_row A = 2 then Smith_2xn A + else if dim_col A = 1 then let (P,S) = Smith_nx1 A in (P,S,1\<^sub>m 1) + else if dim_col A = 2 then Smith_nx2 A + else + let A1 = mat_of_row (Matrix.row A 0); + A2 = mat_of_rows (dim_col A) [Matrix.row A i. i \ [1..r (P1*A2*Q1); + D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]; + E = mat_of_rows (dim_col A) [Matrix.row C i. i \ [2..r (E*Q2); + (P_H2, H2) = reduce_column div_op H; + (H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1; + (P3,S',Q3) = Smith_mxn H2_DR; + S = four_block_mat (Matrix.mat 1 1 (\(a, b). H $$ (0, 0))) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_row A - 1) 1) S'; + P1' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_row A - 1)) (0\<^sub>m (dim_row A - 1) 1) P1; + P2' = four_block_mat P2 (0\<^sub>m 2 (dim_row A - 2)) (0\<^sub>m (dim_row A - 2) 2) (1\<^sub>m (dim_row A - 2)); + P3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_row A - 1)) (0\<^sub>m (dim_row A - 1) 1) P3; + Q3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q3 + in (P3' * P_H2 * P2' * P1',S, Q1 * Q2 * Q3') +)" + by pat_completeness fast +(*Termination is guaranteed since the algorithm is recursively applied to a + submatrix with less rows*) + + +(*Now I introduce it again*) +declare Smith_2xn.simps[simp] + +lemma Smith_mxn_dom_nm_less_2: + assumes A: "A \ carrier_mat m n" and mn: "n\2 \ m\2" + shows "Smith_mxn_dom A" + by (rule Smith_mxn.domintros, insert assms, auto) (*Takes a while*) + +lemma Smith_mxn_pinduct_carrier_less_2: + assumes A: "A \ carrier_mat m n" and mn: "n\2 \ m\2" + shows "fst (Smith_mxn A) \ carrier_mat m m + \ fst (snd (Smith_mxn A)) \ carrier_mat m n + \ snd (snd (Smith_mxn A)) \ carrier_mat n n" +proof - + have A_dom: "Smith_mxn_dom A" using Smith_mxn_dom_nm_less_2[OF assms] by simp + show ?thesis +proof (cases "dim_row A = 0 \ dim_col A = 0") + case True + have "Smith_mxn A = (1\<^sub>m (dim_row A),A,1\<^sub>m (dim_col A))" + using Smith_mxn.psimps[OF A_dom] True by auto + thus ?thesis using A by auto +next + case False note 1 = False + show ?thesis + proof (cases "dim_row A = 1") + case True + have "Smith_mxn A = (1\<^sub>m 1, Smith_1xn A)" + using Smith_mxn.psimps[OF A_dom] True 1 by auto + then show ?thesis using Smith_1xn_works unfolding is_SNF_def + by (smt Smith_1xn_aux_Q_carrier Smith_1xn_aux_S'_AQ' Smith_1xn_def True assms(1) carrier_matD + carrier_matI diff_less fst_conv index_mult_mat not_gr0 one_carrier_mat prod.collapse + right_mult_one_mat' snd_conv zero_less_one_class.zero_less_one) + next + case False note 2 = False + then show ?thesis + proof (cases "dim_row A = 2") + case True + hence A': "A \ carrier_mat 2 n" using A by auto + have "Smith_mxn A = Smith_2xn A" using Smith_mxn.psimps[OF A_dom] True 1 2 by auto + then show ?thesis using is_SNF_Smith_2xn[OF A'] A unfolding is_SNF_def + by (metis (mono_tags, lifting) carrier_matD carrier_mat_triv case_prod_beta index_mult_mat(2,3)) + next + case False note 3 = False + show ?thesis + proof (cases "dim_col A = 1") + case True + hence A': "A \ carrier_mat m 1" using A by auto + have "Smith_mxn A = (let (P,S) = Smith_nx1 A in (P,S,1\<^sub>m 1))" + using Smith_mxn.psimps[OF A_dom] True 1 2 3 by auto + then show ?thesis using Smith_nx1_works[OF A'] A unfolding is_SNF_def + by (metis (mono_tags, lifting) carrier_matD carrier_mat_triv case_prod_unfold + index_mult_mat(2,3) surjective_pairing) + next + case False + hence "dim_col A = 2" using 1 2 3 mn A by auto + hence A': "A \ carrier_mat m 2" using A by auto + hence "Smith_mxn A = Smith_nx2 A" + using Smith_mxn.psimps[OF A_dom] 1 2 3 False by auto + then show ?thesis using is_SNF_Smith_nx2[OF A'] A unfolding is_SNF_def by force + qed + qed + qed +qed +qed + +lemma Smith_mxn_pinduct_carrier_ge_2: "\Smith_mxn_dom A; A \ carrier_mat m n; m>2; n>2\ \ + fst (Smith_mxn A) \ carrier_mat m m + \ fst (snd (Smith_mxn A)) \ carrier_mat m n + \ snd (snd (Smith_mxn A)) \ carrier_mat n n" +proof (induct arbitrary: m n rule: Smith_mxn.pinduct) + case (1 A) + note A_dom = 1(1) + note A = "1.prems"(1) + note m = "1.prems"(2) + note n = "1.prems"(3) + define A1 where "A1 = mat_of_row (Matrix.row A 0)" + define A2 where "A2 = mat_of_rows (dim_col A) [Matrix.row A i. i \ [1..r (P1*A2*Q1)" + define D where "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]" + define E where "E = mat_of_rows (dim_col A) [Matrix.row C i. i \ [2..r (E*Q2)" + obtain P_H2 H2 where P_H2H2: "(P_H2, H2) = reduce_column div_op H" by (metis surj_pair) + obtain H2_UL H2_UR H2_DL H2_DR where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1" + by (metis split_block_def) + obtain P3 S' Q3 where P3S'Q3: "(P3,S',Q3) = Smith_mxn H2_DR" by (metis prod_cases3) + define S where "S = four_block_mat (Matrix.mat 1 1 (\(a, b). H $$ (0, 0))) (0\<^sub>m 1 (dim_col A - 1)) + (0\<^sub>m (dim_row A - 1) 1) S'" + define P1' where "P1' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_row A - 1)) (0\<^sub>m (dim_row A - 1) 1) P1" + define P2' where "P2' = four_block_mat P2 (0\<^sub>m 2 (dim_row A - 2)) (0\<^sub>m (dim_row A - 2) 2) (1\<^sub>m (dim_row A - 2))" + define P3' where "P3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_row A - 1)) (0\<^sub>m (dim_row A - 1) 1) P3" + define Q3' where "Q3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q3" + have A1: "A1 \ carrier_mat 1 n" unfolding A1_def using A by auto + have A2: "A2 \ carrier_mat (m-1) n" unfolding A2_def using A by auto + have "fst (Smith_mxn A2) \ carrier_mat (m-1) (m-1) + \ fst (snd (Smith_mxn A2)) \ carrier_mat (m-1) n + \ snd (snd (Smith_mxn A2)) \ carrier_mat n n" + proof (cases "2 < m - 1") + case True + show ?thesis by (rule "1.hyps"(2), insert A m n A2_def A1_def True id, auto) + next + case False + hence "m=3" using m by auto + hence A2': "A2 \ carrier_mat 2 n" using A2 by auto + have A2_dom: "Smith_mxn_dom A2" by (rule Smith_mxn.domintros, insert A2', auto) + have "dim_row A2 = 2" using A2 A2' by fast + hence "Smith_mxn A2 = Smith_2xn A2" + using n unfolding Smith_mxn.psimps[OF A2_dom] by auto + then show ?thesis using is_SNF_Smith_2xn[OF A2'] m A2 unfolding is_SNF_def split_beta + by (metis carrier_matD carrier_matI index_mult_mat(2,3)) + qed + hence P1: "P1 \ carrier_mat (m-1) (m-1)" + and D1: "D1 \ carrier_mat (m-1) n" + and Q1: "Q1 \ carrier_mat n n" using P1D1Q1 by (metis fst_conv snd_conv)+ + have "C \ carrier_mat (1 + (m-1)) n" unfolding C_def + by (rule carrier_append_rows, insert P1 D1 Q1 A1, auto) + hence C: "C \ carrier_mat m n" using m by simp + have D: "D \ carrier_mat 2 n" unfolding D_def using C A by auto + have E: "E \ carrier_mat (m-2) n" unfolding E_def using A by auto + have P2: "P2 \ carrier_mat 2 2" and Q2: "Q2 \ carrier_mat n n" + using is_SNF_Smith_2xn[OF D] P2FQ2 D unfolding is_SNF_def by auto + have "H \ carrier_mat (2 + (m-2)) n" unfolding H_def + by (rule carrier_append_rows, insert P2 D Q2 E, auto) + hence H: "H \ carrier_mat m n" using m by auto + have H2: "H2 \ carrier_mat m n" using m H P_H2H2 reduce_column by blast + have H2_DR: "H2_DR \ carrier_mat (m - 1) (n - 1)" + by (rule split_block(4)[OF split_H2[symmetric]], insert H2 m n, auto) + have "fst (Smith_mxn H2_DR) \ carrier_mat (m-1) (m-1) + \ fst (snd (Smith_mxn H2_DR)) \ carrier_mat (m-1) (n-1) + \ snd (snd (Smith_mxn H2_DR)) \ carrier_mat (n-1) (n-1)" + proof (cases "2 2 carrier_mat (m-1) 2" using H2_DR n3 by auto + hence "dim_col H2_DR = 2" by simp + hence "Smith_mxn H2_DR = Smith_nx2 H2_DR" + using n H2_DR' True unfolding Smith_mxn.psimps[OF H2_DR_dom] by auto + then show ?thesis using is_SNF_Smith_nx2[OF H2_DR'] m H2_DR unfolding is_SNF_def by auto + next + case False + hence m3: "m=3" using m_eq_3_or_n_eq_3 n m by auto + have H2_DR_dom: "Smith_mxn_dom H2_DR" + by (rule Smith_mxn.domintros, insert H2_DR m3, auto) + have H2_DR': "H2_DR \ carrier_mat 2 (n-1)" using H2_DR m3 by auto + hence "dim_row H2_DR = 2" by simp + hence "Smith_mxn H2_DR = Smith_2xn H2_DR" + using n H2_DR' unfolding Smith_mxn.psimps[OF H2_DR_dom] by auto + then show ?thesis using is_SNF_Smith_2xn[OF H2_DR'] m H2_DR unfolding is_SNF_def by force + qed + qed + hence P3: "P3 \ carrier_mat (m-1) (m-1)" + and S': "S'\ carrier_mat (m-1) (n-1)" + and Q3: "Q3 \ carrier_mat (n-1) (n-1)" using P3S'Q3 by (metis fst_conv snd_conv)+ + have Smith_final: "Smith_mxn A = (P3' * P_H2 * P2' * P1', S, Q1 * Q2 * Q3')" + proof - + have P1_def: "P1 = fst (Smith_mxn A2)" and D1_def: "D1 = fst (snd (Smith_mxn A2))" + and Q1_def: "Q1 = snd (snd (Smith_mxn A2))" using P1D1Q1 by (metis fstI sndI)+ + have P2_def: "P2 = fst (Smith_2xn D)" and F_def: "F = fst (snd (Smith_2xn D))" + and Q2_def: "Q2 = snd (snd (Smith_2xn D))" using P2FQ2 by (metis fstI sndI)+ + have P_H2_def: "P_H2 = fst (reduce_column div_op H)" + and H2_def: "H2 = snd (reduce_column div_op H)" + using P_H2H2 by (metis fstI sndI)+ + have H2_UL_def: "H2_UL = fst (split_block H2 1 1)" + and H2_UR_def: "H2_UR = fst (snd (split_block H2 1 1))" + and H2_DL_def: "H2_DL = fst (snd (snd (split_block H2 1 1)))" + and H2_DR_def: "H2_DR = snd (snd (snd (split_block H2 1 1)))" + using split_H2 by (metis fstI sndI)+ + have P3_def: "P3 = fst (Smith_mxn H2_DR)" + and S'_def: "S' = fst (snd (Smith_mxn H2_DR))" + and Q3_def: "Q3 = (snd (snd (Smith_mxn H2_DR)))" using P3S'Q3 by (metis fstI sndI)+ + note aux = Smith_mxn.psimps[OF A_dom] Let_def split_beta + A1_def[symmetric] A2_def[symmetric] P1_def[symmetric] D1_def[symmetric] Q1_def[symmetric] + C_def[symmetric] D_def[symmetric] E_def[symmetric] P2_def[symmetric] Q2_def[symmetric] + F_def[symmetric] H_def[symmetric] P_H2_def[symmetric] H2_def[symmetric] H2_UL_def[symmetric] + H2_DL_def[symmetric] H2_UR_def[symmetric] H2_DR_def[symmetric] P3_def[symmetric] S'_def[symmetric] + Q3_def[symmetric] P1'_def[symmetric] P2'_def[symmetric] P3'_def[symmetric] Q1_def[symmetric] + Q2_def[symmetric] Q3'_def[symmetric] S_def[symmetric] + show ?thesis by (rule prod3_intro, unfold aux, insert "1.prems", auto) + qed + have P1': "P1' \ carrier_mat m m" unfolding P1'_def using P1 m by auto + moreover have P2': "P2' \ carrier_mat m m" unfolding P2'_def using P2 m A by auto + moreover have P3': "P3' \ carrier_mat m m" unfolding P3'_def using P3 m by auto + moreover have P_H2: "P_H2 \ carrier_mat m m" using reduce_column[OF H P_H2H2] m by simp + moreover have "S \ carrier_mat m n" unfolding S_def using H A S' + by (auto, smt C One_nat_def Suc_pred \C \ carrier_mat (1 + (m - 1)) n\ carrier_matD carrier_matI + dim_col_mat(1) dim_row_mat(1) index_mat_four_block n neq0_conv plus_1_eq_Suc zero_order(3)) + moreover have "Q3' \ carrier_mat n n" unfolding Q3'_def using Q3 n by auto + ultimately show ?case using Smith_final Q1 Q2 by auto +qed + + +corollary Smith_mxn_pinduct_carrier: "\Smith_mxn_dom A; A \ carrier_mat m n\ \ + fst (Smith_mxn A) \ carrier_mat m m + \ fst (snd (Smith_mxn A)) \ carrier_mat m n + \ snd (snd (Smith_mxn A)) \ carrier_mat n n" + using Smith_mxn_pinduct_carrier_ge_2 Smith_mxn_pinduct_carrier_less_2 + by (meson linorder_not_le) + + +termination proof (relation "measure (\A. dim_row A)") + fix A A1 A2 xb P1 y D1 Q1 C D E xf P2 yb Q2 F yc H xj P_H2 H2 xl xm ye xn yf xo yg + assume 1: "\ (dim_row A = 0 \ dim_col A = 0)" and 2: "dim_row A \ 1" + and 3: "dim_row A \ 2" and 4: "dim_col A \ 1" and 5: "dim_col A \ 2" + and 6: "A1 = mat_of_row (Matrix.row A 0)" + and xa_def: "A2 = mat_of_rows (dim_col A) (map (Matrix.row A) [1..r P1* A2 * Q1 " + and D_def: "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1] " + and E_def: "E = mat_of_rows (dim_col A) (map (Matrix.row C) [2..r E * Q2 " and xj: "xj = reduce_column div_op H " + and P_H2_H2: "(P_H2, H2) = xj" and b4: "xl = split_block H2 1 1 " + and b1: "(xm, ye) = xl" and b2: "(xn, yf) = ye" and b3: "(xo, yg) = yf" + and A2_dom: "Smith_mxn_dom A2" + let ?m = "dim_row A" + let ?n = "dim_col A" + have m: "2< ?m" and n: "2 < ?n" using 1 2 3 4 5 6 by auto + have A1: "A1 \ carrier_mat 1 (dim_col A)" using 6 by auto + have A2: "A2 \ carrier_mat (dim_row A - 1) (dim_col A)" using xa_def by auto + have "fst (Smith_mxn A2) \ carrier_mat (?m-1) (?m-1) + \ fst (snd (Smith_mxn A2)) \ carrier_mat (?m-1) ?n + \ snd (snd (Smith_mxn A2)) \ carrier_mat ?n ?n" + by (rule Smith_mxn_pinduct_carrier[OF A2_dom A2]) + hence P1: "P1\ carrier_mat (?m-1) (?m-1)"and D1: "D1 \ carrier_mat (?m-1) ?n" + and Q1: "Q1 \ carrier_mat ?n ?n" using P1_y_xb D1_Q1_y xa_def xb_def by (metis fstI sndI)+ + have C: "C \ carrier_mat ?m ?n" unfolding C_def using A1 Q1 P1 A2 Q1 + by (smt 1 Suc_pred card_num_simps(30) carrier_append_rows mult_carrier_mat neq0_conv plus_1_eq_Suc) + have D: "D \ carrier_mat 2 ?n" unfolding D_def using C by auto + have E: "E \ carrier_mat (?m-2) ?n" unfolding E_def using C m by auto + have P2FQ2: "(P2,F,Q2) = Smith_2xn D" using F_Q2_yb P2_yb_xf xf by blast + have P2: "P2\carrier_mat 2 2" and F: "F \ carrier_mat 2 ?n" and Q2: "Q2 \ carrier_mat ?n ?n" + using is_SNF_Smith_2xn[OF D] D P2FQ2 unfolding is_SNF_def by auto + have "H \ carrier_mat (2 + (?m-2)) ?n" + by (unfold H_def, rule carrier_append_rows, insert D Q2 P2 E, auto) + hence H: "H \ carrier_mat ?m ?n" using m by auto + have H2: "H2 \ carrier_mat (dim_row H) (dim_col H)" + and P_H2: "P_H2 \ carrier_mat (dim_row A) (dim_row A)" + using reduce_column[OF H xj[unfolded P_H2_H2[symmetric]]] m H by auto + have "dim_row yg < dim_row H2" + by (rule split_block4_decreases_dim_row, insert b1 b2 b3 b4 m n H H2, auto) + also have "... = dim_row A" using H2 H by auto + finally show "(yg, A) \ measure dim_row" unfolding in_measure . +qed (auto) + + +lemma is_SNF_Smith_mxn_less_2: + assumes A: "A \ carrier_mat m n" and mn: "n\2 \ m\2" + shows "is_SNF A (Smith_mxn A)" +proof - + show ?thesis + proof (cases "dim_row A = 0 \ dim_col A = 0") + case True + have "Smith_mxn A = (1\<^sub>m (dim_row A),A,1\<^sub>m (dim_col A))" + using Smith_mxn.simps True by auto + thus ?thesis using A True unfolding is_SNF_def by auto + next + case False note 1 = False + show ?thesis + proof (cases "dim_row A = 1") + case True + have "Smith_mxn A = (1\<^sub>m 1, Smith_1xn A)" + using Smith_mxn.simps True 1 by auto + then show ?thesis using Smith_1xn_works by (metis True carrier_mat_triv surj_pair) + next + case False note 2 = False + then show ?thesis + proof (cases "dim_row A = 2") + case True + hence A': "A \ carrier_mat 2 n" using A by auto + have "Smith_mxn A = Smith_2xn A" using Smith_mxn.simps True 1 2 by auto + then show ?thesis using is_SNF_Smith_2xn[OF A'] A by auto + next + case False note 3 = False + show ?thesis + proof (cases "dim_col A = 1") + case True + hence A': "A \ carrier_mat m 1" using A by auto + have "Smith_mxn A = (let (P,S) = Smith_nx1 A in (P,S,1\<^sub>m 1))" + using Smith_mxn.simps True 1 2 3 by auto + then show ?thesis using Smith_nx1_works[OF A'] A by (auto simp add: case_prod_beta) + next + case False + hence "dim_col A = 2" using 1 2 3 mn A by auto + hence A': "A \ carrier_mat m 2" using A by auto + hence "Smith_mxn A = Smith_nx2 A" + using Smith_mxn.simps 1 2 3 False by auto + then show ?thesis using is_SNF_Smith_nx2[OF A'] A by force + qed + qed + qed + qed +qed + + +lemma is_SNF_Smith_mxn_ge_2: + assumes A: "A \ carrier_mat m n" and m: "m>2" and n: "n>2" + shows "is_SNF A (Smith_mxn A)" + using A m n +proof (induct A arbitrary: m n rule: Smith_mxn.induct) + case (1 A) + note A = "1.prems"(1) + note m = "1.prems"(2) + note n = "1.prems"(3) + have A_dim_not0: "\ (dim_row A = 0 \ dim_col A = 0)" and A_dim_row_not1: "dim_row A \ 1" + and A_dim_row_not2: "dim_row A \ 2" and A_dim_col_not1: "dim_col A \ 1" + and A_dim_col_not2: "dim_col A \ 2" + using A m n by auto + note A_dim_intro = A_dim_not0 A_dim_row_not1 A_dim_row_not2 A_dim_col_not1 A_dim_col_not2 + define A1 where "A1 = mat_of_row (Matrix.row A 0)" + define A2 where "A2 = mat_of_rows (dim_col A) [Matrix.row A i. i \ [1..r (P1*A2*Q1)" + define D where "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]" + define E where "E = mat_of_rows (dim_col A) [Matrix.row C i. i \ [2..r (E*Q2)" + obtain P_H2 H2 where P_H2H2: "(P_H2, H2) = reduce_column div_op H" by (metis surj_pair) + obtain H2_UL H2_UR H2_DL H2_DR where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1" + by (metis split_block_def) + obtain P3 S' Q3 where P3S'Q3: "(P3,S',Q3) = Smith_mxn H2_DR" by (metis prod_cases3) + define S where "S = four_block_mat (Matrix.mat 1 1 (\(a, b). H $$ (0, 0))) (0\<^sub>m 1 (dim_col A - 1)) + (0\<^sub>m (dim_row A - 1) 1) S'" + define P1' where "P1' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_row A - 1)) (0\<^sub>m (dim_row A - 1) 1) P1" + define P2' where "P2' = four_block_mat P2 (0\<^sub>m 2 (dim_row A - 2)) (0\<^sub>m (dim_row A - 2) 2) (1\<^sub>m (dim_row A - 2))" + define P3' where "P3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_row A - 1)) (0\<^sub>m (dim_row A - 1) 1) P3" + define Q3' where "Q3' = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_col A - 1) 1) Q3" + have Smith_final: "Smith_mxn A = (P3' * P_H2 * P2' * P1', S, Q1 * Q2 * Q3')" + proof - + have P1_def: "P1 = fst (Smith_mxn A2)" and D1_def: "D1 = fst (snd (Smith_mxn A2))" + and Q1_def: "Q1 = snd (snd (Smith_mxn A2))" using P1D1Q1 by (metis fstI sndI)+ + have P2_def: "P2 = fst (Smith_2xn D)" and F_def: "F = fst (snd (Smith_2xn D))" + and Q2_def: "Q2 = snd (snd (Smith_2xn D))" using P2FQ2 by (metis fstI sndI)+ + have P_H2_def: "P_H2 = fst (reduce_column div_op H)" + and H2_def: "H2 = snd (reduce_column div_op H)" + using P_H2H2 by (metis fstI sndI)+ + have H2_UL_def: "H2_UL = fst (split_block H2 1 1)" + and H2_UR_def: "H2_UR = fst (snd (split_block H2 1 1))" + and H2_DL_def: "H2_DL = fst (snd (snd (split_block H2 1 1)))" + and H2_DR_def: "H2_DR = snd (snd (snd (split_block H2 1 1)))" + using split_H2 by (metis fstI sndI)+ + have P3_def: "P3 = fst (Smith_mxn H2_DR)" and S'_def: "S' = fst (snd (Smith_mxn H2_DR))" + and Q3_def: "Q3 = (snd (snd (Smith_mxn H2_DR)))" using P3S'Q3 by (metis fstI sndI)+ + note aux = Smith_mxn.simps[of A] Let_def split_beta + A1_def[symmetric] A2_def[symmetric] P1_def[symmetric] D1_def[symmetric] Q1_def[symmetric] + C_def[symmetric] D_def[symmetric] E_def[symmetric] P2_def[symmetric] Q2_def[symmetric] + F_def[symmetric] H_def[symmetric] P_H2_def[symmetric] H2_def[symmetric] H2_UL_def[symmetric] + H2_DL_def[symmetric] H2_UR_def[symmetric] H2_DR_def[symmetric] P3_def[symmetric] S'_def[symmetric] + Q3_def[symmetric] P1'_def[symmetric] P2'_def[symmetric] P3'_def[symmetric] Q1_def[symmetric] + Q2_def[symmetric] Q3'_def[symmetric] S_def[symmetric] + show ?thesis by (rule prod3_intro, unfold aux, insert "1.prems", auto) + qed + show ?case + proof (unfold Smith_final, rule is_SNF_intro) + have A1[simp]: "A1 \ carrier_mat 1 n" unfolding A1_def using A by auto + have A2[simp]: "A2 \ carrier_mat (m-1) n" unfolding A2_def using A by auto + have is_SNF_A2: "is_SNF A2 (Smith_mxn A2)" + proof (cases "n \ 2 \ m - 1 \ 2") + case True + then show ?thesis using is_SNF_Smith_mxn_less_2[OF A2] by simp + next + case False + hence n1: "2 carrier_mat (m-1) (m-1)" + and inv_P1: "invertible_mat P1" + and Q1: "Q1 \ carrier_mat n n" and inv_Q1: "invertible_mat Q1" + and SNF_P1A2Q1: "Smith_normal_form_mat (P1*A2*Q1)" + using is_SNF_A2 P1D1Q1 A2 A n m unfolding is_SNF_def by auto + have C[simp]: "C \ carrier_mat m n" unfolding C_def using P1 Q1 A1 A2 m + by (smt "1"(3) A_dim_not0 Suc_pred card_num_simps(30) carrier_append_rows carrier_matD + carrier_mat_triv index_mult_mat(2,3) neq0_conv plus_1_eq_Suc) + have D[simp]: "D \ carrier_mat 2 n" unfolding D_def using A m by auto + have is_SNF_D: "is_SNF D (Smith_2xn D)" by (rule is_SNF_Smith_2xn[OF D]) + hence P2[simp]: "P2 \ carrier_mat 2 2" and inv_P2: "invertible_mat P2" + and Q2[simp]: "Q2 \ carrier_mat n n" and inv_Q2: "invertible_mat Q2" + and F[simp]: "F \ carrier_mat 2 n" and F_P2DQ2: "F = P2*D*Q2" + and SNF_F: "Smith_normal_form_mat F" + using P2FQ2 D_def A unfolding is_SNF_def by auto + have E[simp]: "E \ carrier_mat (m-2) n" unfolding E_def using A by auto + have H_aux: "H \ carrier_mat (2 + (m-2)) n" unfolding H_def + by (rule carrier_append_rows, insert P2 D Q2 E F_P2DQ2 F A m n mult_carrier_mat, force) + hence H[simp]: "H \ carrier_mat m n" using m by auto + have H2[simp]: "H2 \ carrier_mat m n" using m H P_H2H2 A reduce_column by blast + have H2_DR[simp]: "H2_DR \ carrier_mat (m - 1) (n - 1)" + by (rule split_block(4)[OF split_H2[symmetric]], insert H2 m n A H, auto, insert H2, blast+) + have P1'[simp]: "P1' \ carrier_mat m m" unfolding P1'_def using P1 m by auto + have P2'[simp]: "P2' \ carrier_mat m m" unfolding P2'_def using P2 m A m + by (metis (no_types, lifting) H H_aux carrier_matD carrier_mat_triv + index_mat_four_block(2,3) index_one_mat(2,3)) + have is_SNF_H2_DR: "is_SNF H2_DR (Smith_mxn H2_DR)" + proof (cases "2 < m - 1 \ 2 < n - 1") + case True + hence m1: "22 \ n-1\2" by auto + then show ?thesis using H2_DR is_SNF_Smith_mxn_less_2 by blast + qed + hence P3[simp]: "P3 \ carrier_mat (m-1) (m-1)" and inv_P3: "invertible_mat P3" + and Q3[simp]: "Q3 \ carrier_mat (n-1) (n-1)" and inv_Q3: "invertible_mat Q3" + and S'[simp]: "S' \ carrier_mat (m-1) (n-1)" and S'_P3H2_DRQ3: "S' = P3 * H2_DR * Q3" + and SNF_S': "Smith_normal_form_mat S'" + using A m n H2_DR P3S'Q3 unfolding is_SNF_def by auto + have P3'[simp]: "P3' \ carrier_mat m m" unfolding P3'_def using P3 m by auto + have P_H2[simp]: "P_H2 \ carrier_mat m m" using reduce_column[OF H P_H2H2] m by simp + have S[simp]: "S \ carrier_mat m n" unfolding S_def using H A S' + by (smt A_dim_intro(1) One_nat_def Suc_pred carrier_matD carrier_matI dim_col_mat(1) + dim_row_mat(1) index_mat_four_block(2,3) nat_neq_iff not_less_zero plus_1_eq_Suc) + have Q3'[simp]: "Q3' \ carrier_mat n n" unfolding Q3'_def using Q3 n by auto + (*The following two goals could have been resolved with Smith_mxn_pinduct_carrier, but we need the + dimensions of each matrix anyway*) + show P_final_carrier: "P3' * P_H2 * P2' * P1' \ carrier_mat (dim_row A) (dim_row A)" + using P3' P_H2 P2' P1' A by (metis carrier_matD carrier_matI index_mult_mat(2,3)) + show Q_final_carrier: "Q1 * Q2 * Q3' \ carrier_mat (dim_col A) (dim_col A)" + using Q1 Q2 Q3' A by (metis carrier_matD carrier_matI index_mult_mat(2,3)) + have inv_P1': "invertible_mat P1'" unfolding P1'_def + by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_P1], insert A P1, auto) + have inv_P2': "invertible_mat P2'" unfolding P2'_def + by (rule invertible_mat_four_block_mat_lower_right_id[OF _ _ _ _ _ inv_P2], insert A m, auto) + have inv_P3': "invertible_mat P3'" unfolding P3'_def + by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_P3], insert A P3, auto) + have inv_P_H2: "invertible_mat P_H2" using reduce_column[OF H P_H2H2] m by simp + show "invertible_mat (P3' * P_H2 * P2' * P1')" using inv_P1' inv_P2' inv_P3' inv_P_H2 + by (meson P1' P2' P3' P_H2 invertible_mult_JNF mult_carrier_mat) + have inv_Q3': "invertible_mat Q3'" unfolding Q3'_def + by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_Q3], insert A Q3, auto) + show "invertible_mat (Q1 * Q2 * Q3')" using inv_Q1 inv_Q2 inv_Q3' + by (meson Q1 Q2 Q3' invertible_mult_JNF mult_carrier_mat) + have A_A1_A2: "A = A1 @\<^sub>r A2" unfolding append_cols_def + proof (rule eq_matI) + have A1_A2': "A1 @\<^sub>r A2 \ carrier_mat (1+(m-1)) n" by (rule carrier_append_rows[OF A1 A2]) + hence A1_A2: "A1 @\<^sub>r A2 \ carrier_mat m n" using m by simp + thus "dim_row A = dim_row (A1 @\<^sub>r A2)" and "dim_col A = dim_col (A1 @\<^sub>r A2)" using A by auto + fix i j assume i: "i < dim_row (A1 @\<^sub>r A2)" and j: "j < dim_col (A1 @\<^sub>r A2)" + show "A $$ (i, j) = (A1 @\<^sub>r A2) $$ (i, j)" + proof (cases "i=0") + case True + have "(A1 @\<^sub>r A2) $$ (i, j) = (A1 @\<^sub>r A2) $$ (0, j)" using True by simp + also have "... = four_block_mat A1 (0\<^sub>m (dim_row A1) 0) A2 (0\<^sub>m (dim_row A2) 0) $$ (0,j)" + unfolding append_rows_def .. + also have "... = A1 $$ (0,j)" using A1 A1_A2 j by auto + also have "... = A $$ (0,j)" unfolding A1_def using A1_A2 A i j by auto + finally show ?thesis using True by simp + next + case False + let ?xs = "(map (Matrix.row A) [1..r A2) $$ (i, j) = four_block_mat A1 (0\<^sub>m (dim_row A1) 0) A2 (0\<^sub>m (dim_row A2) 0) $$ (i,j)" + unfolding append_rows_def .. + also have "... = A2 $$ (i-1,j)" using A1 A1_A2' A2 False i j by auto + also have "... = mat_of_rows (dim_col A) ?xs $$ (i - 1, j)" by (simp add: A2_def) + also have "... = ?xs ! (i-1) $v j" by (rule mat_of_rows_index, insert i False A j m A1_A2, auto) + also have "... = A $$ (i,j)" using False A A1_A2 i j by auto + finally show ?thesis .. + qed + qed + have C_eq: "C = P1' * A * Q1" + proof - + have aux: "(A1 @\<^sub>r A2) * Q1 = ((A1 * Q1) @\<^sub>r (A2*Q1))" + by (rule append_rows_mult_right, insert A1 A2 Q1, auto) + have "P1' * A * Q1 = P1' * (A1 @\<^sub>r A2) * Q1" using A_A1_A2 by simp + also have "... = P1' * ((A1 @\<^sub>r A2) * Q1)" using A A_A1_A2 P1' Q1 assoc_mult_mat by blast + also have "... = P1' * ((A1 * Q1) @\<^sub>r (A2*Q1))" by (simp add: aux) + also have "... = (A1 * Q1) @\<^sub>r (P1 * (A2 * Q1))" + by (rule append_rows_mult_left_id, insert A1 Q1 A2 P1 P1'_def A, auto) + also have "... = (A1 * Q1) @\<^sub>r (P1 * A2 * Q1)" using A2 P1 Q1 by auto + finally show ?thesis unfolding C_def .. + qed + have C_D_E: "C = D @\<^sub>r E" + proof - + let ?xs = "[Matrix.row C 0, Matrix.row C 1]" + let ?ys = "(map (Matrix.row C) [0..<2])" + have xs_ys: "?xs = ?ys" by (simp add: upt_conv_Cons) + have D_rw: "D = mat_of_rows (dim_col C) (map (Matrix.row C) [0..<2])" + unfolding D_def xs_ys using A C by (metis carrier_matD(2)) + have d1: "dim_col A = dim_col C" using A C by blast + have d2: "dim_row A = dim_row C" using A C by blast + show ?thesis unfolding D_rw E_def d1 d2 by (rule append_rows_split, insert m C A d2, auto) + qed + have H_eq: "H = P2' * P1' * A * Q1 * Q2" + proof - + have aux: "((P2 * D) @\<^sub>r E) = P2' * (D @\<^sub>r E)" + by (rule append_rows_mult_left_id2[symmetric, OF D E _ P2], insert P2'_def A, auto) + have "H = P2 * D * Q2 @\<^sub>r E * Q2" by (simp add: H_def) + also have "... = (P2 * D @\<^sub>r E) * Q2" + by (rule append_rows_mult_right[symmetric, OF mult_carrier_mat[OF P2 D] E Q2]) + also have "... = P2' * (D @\<^sub>r E) * Q2" by (simp add: aux) + also have "... = P2' * C * Q2" unfolding C_D_E by simp + also have "... = P2' * (P1' * A * Q1) * Q2" unfolding C_eq by simp + also have "... = P2' * P1' * A * Q1 * Q2" + by (smt A P1' P2' Q1 \P2' * C * Q2 = P2' * (P1' * A * Q1) * Q2\ assoc_mult_mat mult_carrier_mat) + finally show ?thesis . + qed + have P_H2_H_H2: "P_H2 * H = H2" using reduce_column[OF H P_H2H2] m by auto + hence H2_eq: "H2 = P_H2 * P2' * P1' * A * Q1 * Q2" unfolding H_eq + by (smt P1' P1'_def P2' P2'_def P_H2 P_final_carrier Q1 Q2 Q_final_carrier assoc_mult_mat + carrier_matD carrier_mat_triv index_mult_mat(2,3)) + have H2_as_four_block_mat: "H2 = four_block_mat H2_UL H2_UR H2_DL H2_DR" + using split_H2 by (metis (no_types, lifting) H2 P1' P1'_def Q3' Q3'_def carrier_matD + index_mat_four_block(2) index_one_mat(2) split_block(5)) + have H2_UL: "H2_UL \ carrier_mat 1 1" + by (rule split_block(1)[OF split_H2[symmetric], of "m-1" "n-1"], insert H2 A m n, auto, insert H2, blast+) + have H2_UR: "H2_UR \ carrier_mat 1 (n-1)" + by (rule split_block(2)[OF split_H2[symmetric], of "m-1"], insert H2 A m n, auto, insert H2, blast+) + have H2_DL: "H2_DL \ carrier_mat (m-1) 1" + by (rule split_block(3)[OF split_H2[symmetric], of _ "n-1"], insert H2 A m n, auto, insert H2, blast+) + have H2_DR: "H2_DR \ carrier_mat (m-1) (n-1)" + by (rule split_block(4)[OF split_H2[symmetric], of _ "n-1"], insert H2 A m n, auto, insert H2, blast+) + have H_ij_F_ij: "H$$(i,j) = F $$(i,j)" if i: "i<2" and j: "j carrier_mat 2 n" using F F_P2DQ2 by blast + show "E * Q2 \ carrier_mat (m-2) n" using E Q2 using mult_carrier_mat by blast + qed (insert m j i, auto) + also have "... = F $$ (i, j)" using F F_P2DQ2 i by auto + finally show ?thesis . + qed + have isDiagonal_F: "isDiagonal_mat F" + using is_SNF_D P2FQ2 unfolding is_SNF_def Smith_normal_form_mat_def by auto + have H_0j_0: "H $$ (0,j) = 0" if j: "j\{1..m 1 (n-1))" + proof (rule eq_matI) + show "dim_row H2_UR = dim_row (0\<^sub>m 1 (n - 1))" and "dim_col H2_UR = dim_col (0\<^sub>m 1 (n - 1))" + using H2_UR by auto + fix i j assume i: "i < dim_row (0\<^sub>m 1 (n - 1))" and j: "j < dim_col (0\<^sub>m 1 (n - 1))" + have i0: "i=0" using i by auto + have 1: "0 < dim_row H2_UL + dim_row H2_DR" using i H2_UL H2_DR by auto + have 2: "j+1 < dim_col H2_UL + dim_col H2_DR" using j H2_UL H2_DR by auto + have "H2_UR $$ (i, j) = H2 $$ (0,j+1)" + unfolding i0 H2_as_four_block_mat using index_mat_four_block(1)[OF 1 2] H2_UL by auto + also have "... = H $$ (0,j+1)" by (rule H2_0j, insert j, auto) + also have "... = 0" using H_0j_0 j by auto + finally show "H2_UR $$ (i, j) = 0\<^sub>m 1 (n - 1) $$ (i, j)" using i j by auto + qed + have H2_UL00_H00: "H2_UL $$ (0,0) = H $$ (0,0)" + using H2_UL H2_as_four_block_mat H2_0j n by fastforce + have F00_dvd_Dij: "F$$(0,0) dvd D$$(i,j)" if i: "i<2" and j: "jm (m - 1) 1)" + proof (rule eq_matI) + show "dim_row (H2_DL) = dim_row (0\<^sub>m (m - 1) 1)" + and "dim_col (H2_DL) = dim_col (0\<^sub>m (m - 1) 1)" using P3 H2_DL A by auto + fix i j assume i: "i < dim_row (0\<^sub>m (m - 1) 1)" and j: "j < dim_col (0\<^sub>m (m - 1) 1)" + have j0: "j=0" using j by auto + have "(H2_DL) $$ (i, j) = H2 $$ (i+1,0)" + using H2_UR H2_UR_0 n j0 H2 H2_UL H2_as_four_block_mat i by auto + also have "... = 0" + proof (cases "i=0") + case True + have "H2 $$ (1,0) = H $$ (1,0)" by (rule reduce_column_preserves2[OF H P_H2H2], insert m n, auto) + also have "... = F $$ (1,0)" by (rule H_ij_F_ij, insert n, auto) + also have "... = 0" using isDiagonal_F F n unfolding isDiagonal_mat_def by auto + finally show ?thesis by (simp add: True) + next + case False + show ?thesis + proof (rule reduce_column_works(1)[OF H P_H2H2]) + show "H $$ (0, 0) dvd H $$ (i + 1, 0)" using H_00_dvd_H_i0 False i by simp + show "\j\{1.. {2..m (m - 1) 1 $$ (i, j)" using i j j0 by auto + qed + have "P3'*H2 = four_block_mat H2_UL H2_UR (P3 * H2_DL) (P3 * H2_DR)" + proof - + have "P3'*H2 = four_block_mat + (1\<^sub>m 1 * H2_UL + 0\<^sub>m 1 (dim_row A - 1) * H2_DL) (1\<^sub>m 1 * H2_UR + 0\<^sub>m 1 (dim_row A - 1) * H2_DR) + (0\<^sub>m (dim_row A - 1) 1 * H2_UL + P3 * H2_DL) (0\<^sub>m (dim_row A - 1) 1 * H2_UR + P3 * H2_DR)" + unfolding P3'_def H2_as_four_block_mat + by (rule mult_four_block_mat[OF _ _ _ P3 H2_UL H2_UR H2_DL H2_DR], insert A, auto) + also have "... = four_block_mat H2_UL H2_UR (P3 * H2_DL) (P3 * H2_DR)" + by (rule cong_four_block_mat, insert H2_UL A m H2_DL H2_DR H2_UR P3, auto) + finally show ?thesis . + qed + hence P3'_H2_as_four_block_mat: "P3'*H2 = four_block_mat H2_UL (0\<^sub>m 1 (n-1)) (0\<^sub>m (m - 1) 1) (P3 * H2_DR)" + unfolding H2_UR_0 H2_DL_0 using P3 by auto + also have "... * Q3' = S" (is "?lhs = ?rhs") + proof - + have "?lhs = four_block_mat H2_UL (0\<^sub>m 1 (n-1)) (0\<^sub>m (m - 1) 1) (P3 * H2_DR) + * four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (n - 1)) (0\<^sub>m (n - 1) 1) Q3" unfolding Q3'_def using A by auto + also have "... = + four_block_mat (H2_UL * 1\<^sub>m 1 + (0\<^sub>m 1 (n-1)) * 0\<^sub>m (n - 1) 1) (H2_UL * 0\<^sub>m 1 (n - 1) + (0\<^sub>m 1 (n-1)) * Q3) + (0\<^sub>m (m - 1) 1 * 1\<^sub>m 1 + P3 * H2_DR * 0\<^sub>m (n - 1) 1) (0\<^sub>m (m - 1) 1 * 0\<^sub>m 1 (n - 1) + P3 * H2_DR * Q3)" + by (rule mult_four_block_mat[OF H2_UL], insert P3 H2_DR Q3, auto) + also have "... = four_block_mat H2_UL (0\<^sub>m 1 (n - 1)) (0\<^sub>m (m - 1) 1) (P3 * H2_DR * Q3)" + by (rule cong_four_block_mat, insert H2_UL A m H2_DL H2_DR H2_UR P3 Q3, auto) + also have "... = four_block_mat (Matrix.mat 1 1 (\(a, b). H $$ (0, 0))) + (0\<^sub>m 1 (dim_col A - 1)) (0\<^sub>m (dim_row A - 1) 1) S'" + by (rule cong_four_block_mat, insert A S'_P3H2_DRQ3 H2_UL00_H00 H2_UL, auto) + finally show ?thesis unfolding S_def by simp + qed + finally have P3'_H2_Q3'_S: "P3'*H2*Q3' = S" . + have S_as_four_block_mat: "S = four_block_mat H2_UL (0\<^sub>m 1 (n - 1)) (0\<^sub>m (m - 1) 1) S'" + unfolding S_def by (rule cong_four_block_mat, insert A S'_P3H2_DRQ3 H2_UL00_H00 H2_UL, auto) + show "S = P3' * P_H2 * P2' * P1' * A * (Q1 * Q2 * Q3')" using P3'_H2_Q3'_S unfolding H2_eq + by (smt P1 P1'_def P2' P2'_def P3 P3'_def P_H2 Q1 Q2 Q3' Q3'_def S Q_final_carrier P_final_carrier + assoc_mult_mat carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_mult_mat(2,3)) + have H00_dvd_all_H2: "H $$ (0, 0) dvd H2 $$ (i, j)" if i: "i j \ i < dim_row S \ j < dim_col S" + hence ij: "i \ j" and i: "i < dim_row S" and j: "j < dim_col S" by auto + have i2: "i < dim_row H2_UL + dim_row S'" and j2: "j < dim_col H2_UL + dim_col S'" + using S_as_four_block_mat i j by auto + have "S $$ (i,j) = (if i < dim_row H2_UL then if j < dim_col H2_UL then H2_UL $$ (i, j) + else (0\<^sub>m 1 (n - 1)) $$ (i, j - dim_col H2_UL) else if j < dim_col H2_UL + then (0\<^sub>m (m - 1) 1) $$ (i - dim_row H2_UL, j) else S' $$ (i - dim_row H2_UL, j - dim_col H2_UL))" + by (unfold S_as_four_block_mat, rule index_mat_four_block(1)[OF i2 j2]) + also have "... = 0" (is "?lhs = 0") + proof (cases "i = 0 \ j = 0") + case True + then show ?thesis unfolding S_def using ij i j S H2_UL by fastforce + next + case False + have diag_S': "isDiagonal_mat S'" using SNF_S' unfolding Smith_normal_form_mat_def by simp + have i_not_0: "i\0" and j_not_0: "j\0" using False by auto + hence "?lhs = S' $$ (i - dim_row H2_UL, j - dim_col H2_UL)" using i j ij H2_UL by auto + also have "... = 0" using diag_S' S' H2_UL i_not_0 j_not_0 ij unfolding isDiagonal_mat_def + by (smt S_as_four_block_mat add_diff_inverse_nat add_less_cancel_left carrier_matD i + index_mat_four_block(2,3) j less_one) + finally show ?thesis . + qed + finally show "S $$ (i, j) = 0" . + qed + show "\a. a + 1 < min (dim_row S) (dim_col S) \ S $$ (a, a) dvd S $$ (a + 1, a + 1)" + proof safe + fix i assume i: "i + 1 < min (dim_row S) (dim_col S)" + show "S $$ (i, i) dvd S $$ (i + 1, i + 1)" + proof (cases "i=0") + case True + have "S $$ (0, 0) = H $$ (0,0)" using H2_UL H2_UL00_H00 S_as_four_block_mat by auto + also have "... dvd S $$ (1,1)" using H00_dvd_all_S i m n by auto + finally show ?thesis using True by simp + next + case False + have "S $$ (i, i)= S' $$ (i-1, i-1)" using False S_def i by auto + also have "... dvd S' $$ (i, i)" using SNF_S' i S' S unfolding Smith_normal_form_mat_def + by (smt False H2_UL S_as_four_block_mat add.commute add_diff_inverse_nat carrier_matD + index_mat_four_block(2,3) less_one min_less_iff_conj nat_add_left_cancel_less) + also have "... = S $$ (i+1,i+1)" using False S_def i by auto + finally show ?thesis . + qed + qed + qed + qed +qed + +subsection \Soundness theorem\ + +theorem is_SNF_Smith_mxn: + assumes A: "A \ carrier_mat m n" + shows "is_SNF A (Smith_mxn A)" + using is_SNF_Smith_mxn_ge_2[OF A] is_SNF_Smith_mxn_less_2[OF A] by linarith + +declare Smith_mxn.simps[code] + +end + +declare Smith_Impl.Smith_mxn.simps[code_unfold] + +definition T_spec :: "('a::{comm_ring_1} \ 'a \ ('a \ 'a \ 'a)) \ bool" + where "T_spec T = (\a b::'a. let (a1,b1,d) = T a b in + a = a1*d \ b = b1*d \ ideal_generated {a1,b1} = ideal_generated {1})" + +definition D'_spec :: "('a::{comm_ring_1} \ 'a \ 'a \ ('a \ 'a)) \ bool" + where "D'_spec D' = (\a b c::'a. let (p,q) = D' a b c in + ideal_generated{a,b,c} = ideal_generated{1} + \ ideal_generated {p*a,p*b+q*c} = ideal_generated {1})" + +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/SNF_Algorithm_Euclidean_Domain.thy b/thys/Smith_Normal_Form/SNF_Algorithm_Euclidean_Domain.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Algorithm_Euclidean_Domain.thy @@ -0,0 +1,714 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Executable Smith normal form algorithm over Euclidean domains\ + +theory SNF_Algorithm_Euclidean_Domain + imports + Diagonal_To_Smith + Echelon_Form.Examples_Echelon_Form_Abstract + + Elementary_Divisor_Rings + Diagonal_To_Smith_JNF + + Mod_Type_Connect + Show.Show_Instances + Jordan_Normal_Form.Show_Matrix + Show.Show_Poly +begin + +text \This provides an executable implementation of the verified general algorithm, provinding +executable operations over a Euclidean domain.\ + +lemma zero_less_one_type2: "(0::2) < 1" +proof - + have "Mod_Type.from_nat 0 = (0::2)" by (simp add: from_nat_0) + moreover have "Mod_Type.from_nat 1 = (1::2)" using from_nat_1 by blast + moreover have "(Mod_Type.from_nat 0::2) < Mod_Type.from_nat 1" by (rule from_nat_mono, auto) + ultimately show ?thesis by simp +qed + +subsection \Previous code equations\ +(*Firstly, code equations for Mod_Type_Connect.to_hma\<^sub>m*) + +definition "to_hma\<^sub>m_row A i + = (vec_lambda (\j. A $$ (Mod_Type.to_nat i, Mod_Type.to_nat j)))" + +lemma bezout_matrix_row_code [code abstract]: + "vec_nth (to_hma\<^sub>m_row A i) = + (\j. A $$ (Mod_Type.to_nat i, Mod_Type.to_nat j))" + unfolding to_hma\<^sub>m_row_def by auto + +lemma [code abstract]: "vec_nth (Mod_Type_Connect.to_hma\<^sub>m A) = to_hma\<^sub>m_row A" + unfolding Mod_Type_Connect.to_hma\<^sub>m_def unfolding to_hma\<^sub>m_row_def[abs_def] + by auto + + +subsection \An executable algorithm to transform $2 \times 2$ matrices into its Smith normal form +in HOL Analysis\ +(* + +There are several alternatives to obtain an algorithm to transform a 2x2 matrix (over +a euclidean domain) into its Smith normal form. One of them is diagonalize + diagonal to Smith. + +To take advantage of existing results in HOL Analysis (HA), we proceed as follows: + + 1) We implement an algorithm to diagonalize a matrix in HA, taking advantage of the existing + bezout matrix + 2) Then, we transform the diagonal matrix to its Smith normal form using the diagonal_to_Smith + algorithm in HA, already proved. + 3) We define an algorithm in JNF based on the one in HA, which is possible since the types + are known. Then, transfer the results to JNF. +*) + +subclass (in euclidean_ring_gcd) bezout_ring_div +proof qed + +(*value[code] "let (P,S,Q) = (diagonal_to_Smith_PQ ((list_of_list_to_matrix [[4,0],[0,10]])::int^2^2) euclid_ext2) + in (matrix_to_list_of_list P,matrix_to_list_of_list S,matrix_to_list_of_list Q)"*) + +context + fixes bezout::"('a::euclidean_ring_gcd \ 'a \ ('a\'a\'a\'a\'a))" + assumes ib: "is_bezout_ext bezout" +begin + +lemma normalize_bezout_gcd: + assumes b: "(p,q,u,v,d) = bezout a b" + shows "normalize d = gcd a b" +proof - + let ?gcd = "(\a b. case bezout a b of (x, xa,u,v, gcd') \ gcd')" + have is_gcd: "is_gcd ?gcd" by (simp add: ib is_gcd_is_bezout_ext) + have "(?gcd a b) = d" using b by (metis case_prod_conv) + moreover have "normalize (?gcd a b) = normalize (gcd a b)" + proof (rule associatedI) + show "(?gcd a b) dvd (gcd a b)" using is_gcd is_gcd_def by fastforce + show "(gcd a b) dvd (?gcd a b)" by (metis (no_types) gcd_dvd1 gcd_dvd2 is_gcd is_gcd_def) + qed + ultimately show ?thesis by auto +qed + +end + + +lemma bezout_matrix_works_transpose1: + assumes ib: "is_bezout_ext bezout" + and a_not_b: "a \ b" +shows "(A**transpose (bezout_matrix (transpose A) a b i bezout)) $ i $ a + = snd (snd (snd (snd (bezout (A $ i $ a) (A $ i $ b)))))" +proof - + have "(A**transpose (bezout_matrix (transpose A) a b i bezout)) $h i $h a + = transpose (A**transpose (bezout_matrix (transpose A) a b i bezout)) $h a $h i" + by (simp add: transpose_code transpose_row_code) + also have "... = ((bezout_matrix (transpose A) a b i bezout) ** (transpose A)) $h a $h i" + by (simp add: matrix_transpose_mul) + also have "... = snd (snd (snd (snd (bezout ((transpose A) $ a $ i) ((transpose A) $ b $ i)))))" + by (rule bezout_matrix_works1[OF ib a_not_b]) + also have "... = snd (snd (snd (snd (bezout (A $ i $ a) (A $ i $ b)))))" + by (simp add: transpose_code transpose_row_code) + finally show ?thesis . +qed + +lemma invertible_bezout_matrix_transpose: + fixes A::"'a::{bezout_ring_div}^'cols::{finite,wellorder}^'rows" + assumes ib: "is_bezout_ext bezout" + and a_less_b: "a < b" + and aj: "A $h i $h a \ 0" +shows "invertible (transpose (bezout_matrix (transpose A) a b i bezout))" +proof - + have "Determinants.det (bezout_matrix (transpose A) a b i bezout) = 1" + by (rule det_bezout_matrix[OF ib a_less_b], insert aj, auto simp add: transpose_def) + hence "Determinants.det (transpose (bezout_matrix (transpose A) a b i bezout)) = 1" by simp + thus ?thesis by (simp add: invertible_iff_is_unit) +qed + + +(*I will have to ensure that a is not zero before starting the algorithm (moving the pivot)*) +function diagonalize_2x2_aux :: "(('a::euclidean_ring_gcd^2^2) \ ('a^2^2)\('a^2^2)) \ + (('a^2^2) \('a^2^2)\('a^2^2))" + where "diagonalize_2x2_aux (P,A,Q) = +( + let + a = A $h 0 $h 0; + b = A $h 0 $h 1; + c = A $h 1 $h 0; + d = A $h 1 $h 1 in + if a\ 0 \ \ a dvd b then let bezout_mat = transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2) in + diagonalize_2x2_aux (P, A**bezout_mat,Q**bezout_mat) else + if a \ 0 \ \ a dvd c then let bezout_mat = bezout_matrix A 0 1 0 euclid_ext2 + in diagonalize_2x2_aux (bezout_mat**P,bezout_mat**A,Q) else \ \We can divide an get zeros\ + let Q' = column_add (Finite_Cartesian_Product.mat 1) 1 0 (- (b div a)); + P' = row_add (Finite_Cartesian_Product.mat 1) 1 0 (- (c div a)) in + (P'**P,P'**A**Q',Q**Q') +)" by auto + +(*The algorithm terminates since the euclidean size of the A $h 0 $h 0 element gets reduced.*) +termination +proof- + have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2) + have "euclidean_size ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) < euclidean_size (A $h 0 $h 0)" + if a_not_dvd_c: "\ A $h 0 $h 0 dvd A $h 1 $h 0" and a_not0: "A $h 0 $h 0 \ 0" for A::"'a^2^2" + proof- + let ?a = "(A $h 0 $h 0)" let ?c = "(A $h 1 $h 0)" + obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?c" by (metis prod_cases5) + have "(bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0 = d" + by (metis bezout_matrix_works1 ib one_neq_zero pquvd prod.sel(2)) + hence "normalize ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) = normalize d" by auto + also have "... = gcd ?a ?c" by (rule normalize_bezout_gcd[OF ib pquvd]) + finally have "euclidean_size ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) + = euclidean_size (gcd ?a ?c)" by (metis euclidean_size_normalize) + also have "... < euclidean_size ?a" by (rule euclidean_size_gcd_less1[OF a_not0 a_not_dvd_c]) + finally show ?thesis . + qed + moreover have "euclidean_size ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0) + < euclidean_size (A $h 0 $h 0)" + if a_not_dvd_b: "\ A $h 0 $h 0 dvd A $h 0 $h 1" and a_not0: "A $h 0 $h 0 \ 0" for A::"'a^2^2" + proof- + let ?a = "(A $h 0 $h 0)" let ?b = "(A $h 0 $h 1)" + obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?b" by (metis prod_cases5) + have "(A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0 = d" + by (metis bezout_matrix_works_transpose1 ib pquvd prod.sel(2) zero_neq_one) + hence "normalize ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0) = normalize d" by auto + also have "... = gcd ?a ?b" by (rule normalize_bezout_gcd[OF ib pquvd]) + finally have "euclidean_size ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0) + = euclidean_size (gcd ?a ?b)" by (metis euclidean_size_normalize) + also have "... < euclidean_size ?a" by (rule euclidean_size_gcd_less1[OF a_not0 a_not_dvd_b]) + finally show ?thesis . + qed + ultimately show ?thesis + by (relation "Wellfounded.measure (\(P,A,Q). euclidean_size (A $h 0 $h 0))", auto) +qed + + +lemma diagonalize_2x2_aux_works: + assumes "A = P ** A_input ** Q" + and "invertible P" and "invertible Q" + and "(P',D,Q') = diagonalize_2x2_aux (P,A,Q)" + and "A $h 0 $h 0 \ 0" + shows "D = P' ** A_input ** Q' \ invertible P' \ invertible Q' \ isDiagonal D" + using assms +proof (induct "(P,A,Q)" arbitrary: P A Q rule: diagonalize_2x2_aux.induct) + case (1 P A Q) + let ?a = "A $h 0 $h 0" + let ?b = "A $h 0 $h 1" + let ?c = "A $h 1 $h 0" + let ?d = "A $h 1 $h 1" + have a_not_0: "?a \ 0" using "1.prems" by blast + have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2) + have one_not_zero: "1 \ (0::2)" by auto + show ?case + proof (cases "\ ?a dvd ?b") + case True + let ?bezout_mat_right = "transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)" + have "(P', D, Q') = diagonalize_2x2_aux (P, A, Q)" using "1.prems" by blast + also have "... = diagonalize_2x2_aux (P, A** ?bezout_mat_right, Q ** ?bezout_mat_right)" + using True a_not_0 by (auto simp add: Let_def) + finally have eq: "(P',D,Q') = ..." . + show ?thesis + proof (rule "1.hyps"(1)[OF _ _ _ _ _ _ _ _ _ eq]) + have "invertible ?bezout_mat_right" + by (rule invertible_bezout_matrix_transpose[OF ib zero_less_one_type2 a_not_0]) + thus "invertible (Q ** ?bezout_mat_right)" + using "1.prems" invertible_mult by blast + show "A ** ?bezout_mat_right = P ** A_input ** (Q ** ?bezout_mat_right)" + by (simp add: "1.prems" matrix_mul_assoc) + show "(A ** ?bezout_mat_right) $h 0 $h 0 \ 0" + by (metis (no_types, lifting) a_not_0 bezout_matrix_works_transpose1 bezout_matrix_not_zero + bezout_matrix_works1 is_bezout_ext_euclid_ext2 one_neq_zero transpose_code transpose_row_code) + qed (insert True a_not_0 "1.prems", blast+) + next + case False note a_dvd_b = False + show ?thesis + proof (cases "\ ?a dvd ?c") + case True + let ?bezout_mat = "(bezout_matrix A 0 1 0 euclid_ext2)" + have "(P', D, Q') = diagonalize_2x2_aux (P, A, Q)" using "1.prems" by blast + also have "... = diagonalize_2x2_aux (?bezout_mat**P, ?bezout_mat ** A, Q)" + using True a_dvd_b a_not_0 by (auto simp add: Let_def) + finally have eq: "(P',D,Q') = ..." . + show ?thesis + proof (rule "1.hyps"(2)[OF _ _ _ _ _ _ _ _ _ _ eq]) + have "invertible ?bezout_mat" + by (rule invertible_bezout_matrix[OF ib zero_less_one_type2 a_not_0]) + thus "invertible (?bezout_mat ** P)" + using "1.prems" invertible_mult by blast + show "?bezout_mat ** A = (?bezout_mat ** P) ** A_input ** Q" + by (simp add: "1.prems" matrix_mul_assoc) + show "(?bezout_mat ** A) $h 0 $h 0 \ 0" + by (simp add: a_not_0 bezout_matrix_not_zero is_bezout_ext_euclid_ext2) + qed (insert True a_not_0 a_dvd_b "1.prems", blast+) + next + case False + hence a_dvd_c: "?a dvd ?c" by simp + let ?Q' = "column_add (Finite_Cartesian_Product.mat 1) 1 0 (- (?b div ?a))::'a^2^2" + let ?P' = "(row_add (Finite_Cartesian_Product.mat 1) 1 0 (- (?c div ?a)))::'a^2^2" + have eq: "(P', D, Q') = (?P'**P,?P'**A**?Q',Q**?Q')" + using "1.prems" a_dvd_b a_dvd_c a_not_0 by (auto simp add: Let_def) + have d: "isDiagonal (?P'**A**?Q')" + proof - + { + fix a b::2 assume a_not_b: "a \ b" + have "(?P' ** A ** ?Q') $h a $h b = 0" + proof (cases "(a,b) = (0,1)") + case True + hence a0: "a = 0" and b1: "b = 1" by auto + have "(?P' ** A ** ?Q') $h a $h b = (?P' ** (A ** ?Q')) $h a $h b" + by (simp add: matrix_mul_assoc) + also have "... = (A**?Q') $h a $h b" unfolding row_add_mat_1 + by (smt True a_not_b prod.sel(2) row_add_def vec_lambda_beta) + also have "... = 0" unfolding column_add_mat_1 a0 b1 + by (smt Groups.mult_ac(2) a_dvd_b ab_group_add_class.ab_left_minus add_0_left + add_diff_cancel_left' add_uminus_conv_diff column_add_code_nth column_add_row_def + comm_semiring_class.distrib dvd_div_mult_self vec_lambda_beta) + finally show ?thesis . + next + case False + hence a1: "a = 1" and b0: "b = 0" + by (metis (no_types, hide_lams) False a_not_b exhaust_2 zero_neq_one)+ + have "(?P' ** A ** ?Q') $h a $h b = (?P' ** A) $h a $h b" + unfolding a1 b0 column_add_mat_1 + by (simp add: column_add_code_nth column_add_row_def) + also have "... = 0" unfolding row_add_mat_1 a1 b0 + by (simp add: a_dvd_c row_add_def) + finally show ?thesis . + qed} + thus ?thesis unfolding isDiagonal_def by auto + qed + have inv_P': "invertible ?P'" by (rule invertible_row_add[OF one_not_zero]) + have inv_Q': "invertible ?Q'" by (rule invertible_column_add[OF one_not_zero]) + have "invertible (?P'**P)" using "1.prems"(2) inv_P' invertible_mult by blast + moreover have "invertible (Q**?Q')" using "1.prems"(3) inv_Q' invertible_mult by blast + moreover have "D = P' ** A_input ** Q'" + by (metis (no_types, lifting) "1.prems"(1) Pair_inject eq matrix_mul_assoc) + ultimately show ?thesis using eq d by auto + qed + qed +qed + + +definition "diagonalize_2x2 A = + (if A $h 0 $h 0 = 0 then + if A $h 0 $h 1 \ 0 then + let A' = interchange_columns A 0 1; + Q' = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1 in + diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1, A', Q') + else + if A $h 1 $h 0 \ 0 then + let A' = interchange_rows A 0 1; + P' = interchange_rows (Finite_Cartesian_Product.mat 1) 0 1 in + diagonalize_2x2_aux (P', A', Finite_Cartesian_Product.mat 1) + else (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1) + else diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1) +)" + + +lemma diagonalize_2x2_works: + assumes PDQ: "(P,D,Q) = diagonalize_2x2 A" + shows "D = P ** A ** Q \ invertible P \ invertible Q \ isDiagonal D" +proof - + let ?a = "A $h 0 $h 0" + let ?b = "A $h 0 $h 1" + let ?c = "A $h 1 $h 0" + let ?d = "A $h 1 $h 1" + show ?thesis + proof (cases "?a = 0") + case False + hence eq: "(P,D,Q) = diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)" + using PDQ unfolding diagonalize_2x2_def by auto + show ?thesis + by (rule diagonalize_2x2_aux_works[OF _ _ _ eq False], auto simp add: invertible_mat_1) + next + case True note a0 = True + show ?thesis + proof (cases "?b \ 0") + case True + let ?A' = "interchange_columns A 0 1" + let ?Q' = "(interchange_columns (Finite_Cartesian_Product.mat 1) 0 1)::'a^2^2" + have eq: "(P,D,Q) = diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1, ?A', ?Q')" + using PDQ a0 True unfolding diagonalize_2x2_def by (auto simp add: Let_def) + show ?thesis + proof (rule diagonalize_2x2_aux_works[OF _ _ _ eq _]) + show "?A' $h 0 $h 0 \ 0" + by (simp add: True interchange_columns_code interchange_columns_code_nth) + show "invertible ?Q'" by (simp add: invertible_interchange_columns) + show "?A' = Finite_Cartesian_Product.mat 1 ** A ** ?Q'" + by (simp add: interchange_columns_mat_1) + qed (auto simp add: invertible_mat_1) + next + case False note b0 = False + show ?thesis + proof (cases "?c \ 0") + case True + let ?A' = "interchange_rows A 0 1" + let ?P' = "(interchange_rows (Finite_Cartesian_Product.mat 1) 0 1)::'a^2^2" + have eq: "(P,D,Q) = diagonalize_2x2_aux (?P', ?A',Finite_Cartesian_Product.mat 1)" + using PDQ a0 b0 True unfolding diagonalize_2x2_def by (auto simp add: Let_def) + show ?thesis + proof (rule diagonalize_2x2_aux_works[OF _ _ _ eq _]) + show "?A' $h 0 $h 0 \ 0" + by (simp add: True interchange_columns_code interchange_columns_code_nth) + show "invertible ?P'" by (simp add: invertible_interchange_rows) + show "?A' = ?P' ** A ** Finite_Cartesian_Product.mat 1" + by (simp add: interchange_rows_mat_1) + qed (auto simp add: invertible_mat_1) + next + case False + have eq: "(P,D,Q) = (Finite_Cartesian_Product.mat 1, A,Finite_Cartesian_Product.mat 1)" + using PDQ a0 b0 True False unfolding diagonalize_2x2_def by (auto simp add: Let_def) + have "isDiagonal A" unfolding isDiagonal_def using a0 b0 True False + by (metis (full_types) exhaust_2 one_neq_zero) + thus ?thesis using invertible_mat_1 eq by auto + qed + qed + qed +qed + + +definition "diagonalize_2x2_JNF (A::'a::euclidean_ring_gcd mat) + = (let (P,D,Q) = diagonalize_2x2 (Mod_Type_Connect.to_hma\<^sub>m A::'a^2^2) in + (Mod_Type_Connect.from_hma\<^sub>m P,Mod_Type_Connect.from_hma\<^sub>m D,Mod_Type_Connect.from_hma\<^sub>m Q))" + + +(*Obtained via transfer rules*) +lemma diagonalize_2x2_JNF_works: + assumes A: "A \ carrier_mat 2 2" + and PDQ: "(P,D,Q) = diagonalize_2x2_JNF A" + shows "D = P * A * Q \ invertible_mat P \ invertible_mat Q \ isDiagonal_mat D \ P\carrier_mat 2 2 + \ Q \ carrier_mat 2 2 \ D \ carrier_mat 2 2" +proof - + let ?A = "(Mod_Type_Connect.to_hma\<^sub>m A::'a^2^2)" + have A[transfer_rule]: "Mod_Type_Connect.HMA_M A ?A" + using A unfolding Mod_Type_Connect.HMA_M_def by auto + obtain P_HMA D_HMA Q_HMA where PDQ_HMA: "(P_HMA,D_HMA,Q_HMA) = diagonalize_2x2 ?A" + by (metis prod_cases3) +(* have "HMA_M3 (diagonalize_2x2_JNF A) (diagonalize_2x2 ?A)" + using HMA_diagonalize_2x2 A rel_funE by fastforce*) + have P: "P = Mod_Type_Connect.from_hma\<^sub>m P_HMA" and Q: "Q = Mod_Type_Connect.from_hma\<^sub>m Q_HMA" + and D: "D = Mod_Type_Connect.from_hma\<^sub>m D_HMA" + using PDQ_HMA PDQ unfolding diagonalize_2x2_JNF_def + by (metis prod.simps(1) split_conv)+ + have [transfer_rule]: "Mod_Type_Connect.HMA_M P P_HMA" + unfolding Mod_Type_Connect.HMA_M_def using P by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q_HMA" + unfolding Mod_Type_Connect.HMA_M_def using Q by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_M D D_HMA" + unfolding Mod_Type_Connect.HMA_M_def using D by auto + have r: "D_HMA = P_HMA ** ?A ** Q_HMA \ invertible P_HMA \ invertible Q_HMA \ isDiagonal D_HMA" + by (rule diagonalize_2x2_works[OF PDQ_HMA]) + have "D = P * A * Q \ invertible_mat P \ invertible_mat Q \ isDiagonal_mat D" + using r by (transfer, rule) + thus ?thesis using P Q D by auto +qed + + + +(*The full algorithm in HOL Analysis*) +definition "Smith_2x2_eucl A = ( + let (P,D,Q) = diagonalize_2x2 A; + (P',S,Q') = diagonal_to_Smith_PQ D euclid_ext2 + in (P' ** P, S, Q ** Q'))" + +lemma Smith_2x2_eucl_works: + assumes PBQ: "(P,S,Q) = Smith_2x2_eucl A" + shows "S = P ** A ** Q \ invertible P \ invertible Q \ Smith_normal_form S" +proof - + have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2) + obtain P1 D Q1 where P1DQ1: "(P1,D,Q1) = diagonalize_2x2 A" by (metis prod_cases3) + obtain P2 S' Q2 where P2SQ2:"(P2,S',Q2) = diagonal_to_Smith_PQ D euclid_ext2" + by (metis prod_cases3) + have P: "P = P2 ** P1" and S: "S = S'" and Q: "Q = Q1 ** Q2" + by (metis (mono_tags, lifting) PBQ Pair_inject Smith_2x2_eucl_def P1DQ1 P2SQ2 old.prod.case)+ + have 1: "D = P1 ** A ** Q1 \ invertible P1 \ invertible Q1 \ isDiagonal D" + by (rule diagonalize_2x2_works[OF P1DQ1]) + have 2: "S' = P2 ** D ** Q2 \ invertible P2 \ invertible Q2 \ Smith_normal_form S'" + by (rule diagonal_to_Smith_PQ'[OF _ ib P2SQ2], insert 1, auto) + show ?thesis using 1 2 P S Q by (simp add: 2 invertible_mult matrix_mul_assoc) +qed + + +subsection \An executable algorithm to transform $2 \times 2$ matrices into its Smith normal form +in JNF\ +(*The full algorithm in JNF*) +definition "Smith_2x2_JNF_eucl A = ( + let (P,D,Q) = diagonalize_2x2_JNF A; + (P',S,Q') = diagonal_to_Smith_PQ_JNF D euclid_ext2 + in (P' * P, S, Q * Q'))" + +lemma Smith_2x2_JNF_eucl_works: + assumes A: "A \ carrier_mat 2 2" + and PBQ: "(P,S,Q) = Smith_2x2_JNF_eucl A" + shows "is_SNF A (P,S,Q)" +proof - + have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2) + obtain P1 D Q1 where P1DQ1: "(P1,D,Q1) = diagonalize_2x2_JNF A" by (metis prod_cases3) + obtain P2 S' Q2 where P2SQ2: "(P2,S',Q2) = diagonal_to_Smith_PQ_JNF D euclid_ext2" + by (metis prod_cases3) + have P: "P = P2 * P1" and S: "S = S'" and Q: "Q = Q1 * Q2" + by (metis (mono_tags, lifting) PBQ Pair_inject Smith_2x2_JNF_eucl_def P1DQ1 P2SQ2 old.prod.case)+ + have 1: "D = P1 * A * Q1 \ invertible_mat P1 \ invertible_mat Q1 \ isDiagonal_mat D + \ P1 \ carrier_mat 2 2 \ Q1 \ carrier_mat 2 2 \ D \ carrier_mat 2 2" + by (rule diagonalize_2x2_JNF_works[OF A P1DQ1]) + have 2: "S' = P2 * D * Q2 \ invertible_mat P2 \ invertible_mat Q2 \ Smith_normal_form_mat S' + \ P2 \ carrier_mat 2 2 \ S' \ carrier_mat 2 2 \ Q2 \ carrier_mat 2 2" + by (rule diagonal_to_Smith_PQ_JNF[OF _ ib _ P2SQ2], insert 1, auto) + show ?thesis + proof (rule is_SNF_intro) + have dim_Q: "Q \ carrier_mat 2 2" using Q 1 2 by auto + have P1AQ1: "(P1*A*Q1) \ carrier_mat 2 2" using 1 2 A by auto + have rw1: "(P1 * A * Q1) * Q2 = (P1 * A * (Q1 * Q2))" + by (meson "1" "2" A assoc_mult_mat mult_carrier_mat) + have rw2: "(P1 * A * Q) = P1 * (A * Q)" by (rule assoc_mult_mat[OF _ A dim_Q], insert 1, auto) + show "invertible_mat Q" using 1 2 Q invertible_mult_JNF by blast + show "invertible_mat P" using 1 2 P invertible_mult_JNF by blast + have "P2 * D * Q2 = P2 * (P1 * A * Q1) * Q2" using 1 2 by auto + also have "... = P2 * ((P1 * A * Q1) * Q2)" using 1 2 by auto + also have "... = P2 * (P1 * A * (Q1 * Q2))" unfolding rw1 by simp + also have "... = P2 * (P1 * A * Q)" using Q by auto + also have "... = P2 * (P1 * (A * Q))" unfolding rw2 by simp + also have "... = P2 * P1 * (A * Q)" by (rule assoc_mult_mat[symmetric], insert 1 2 A Q, auto) + also have "... = P*(A*Q)" unfolding P by simp + also have "... = P*A*Q" by (rule assoc_mult_mat[symmetric], insert 1 2 A Q P, auto) + finally show "S = P * A * Q" using 1 2 S by auto + qed (insert 1 2 P Q A S, auto) +qed + +subsection \An executable algorithm to transform $1 \times 2$ matrices into its Smith normal form\ + +(*Let's move to prove the case 1x2*) + +(*This is not executable since type 1 is not mod_type*) +definition "Smith_1x2_eucl (A::'a::euclidean_ring_gcd^2^1) = ( + if A $h 0 $h 0 = 0 \ A $h 0 $h 1 \ 0 then + let Q = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1; + A' = interchange_columns A 0 1 in (A',Q) + else + if A $h 0 $h 0 \ 0 \ A $h 0 $h 1 \ 0 then + let bezout_matrix_right = transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2) + in (A ** bezout_matrix_right, bezout_matrix_right) + else (A, Finite_Cartesian_Product.mat 1) + )" + + +lemma Smith_1x2_eucl_works: + assumes SQ: "(S,Q) = Smith_1x2_eucl A" + shows "S = A ** Q \ invertible Q \ S $h 0 $h 1 = 0" +proof (cases "A $h 0 $h 0 = 0 \ A $h 0 $h 1 \ 0") + case True + have Q: "Q = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1" + and S: "S = interchange_columns A 0 1" + using SQ True unfolding Smith_1x2_eucl_def by (auto simp add: Let_def) + have "S $h 0 $h 1 = 0" by (simp add: S True interchange_columns_code interchange_columns_code_nth) + moreover have "invertible Q" using Q invertible_interchange_columns by blast + moreover have "S = A ** Q" by (simp add: Q S interchange_columns_mat_1) + ultimately show ?thesis by simp +next + case False note A00_A01 = False + show ?thesis + proof (cases "A $h 0 $h 0 \ 0 \ A $h 0 $h 1 \ 0") + case True + have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2) + let ?bezout_matrix_right = "transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)" + have Q: "Q = ?bezout_matrix_right" and S: "S = A**?bezout_matrix_right" + using SQ True A00_A01 unfolding Smith_1x2_eucl_def by (auto simp add: Let_def) + have "invertible Q" unfolding Q + by (rule invertible_bezout_matrix_transpose[OF ib zero_less_one_type2], insert True, auto) + moreover have "S $h 0 $h 1 = 0" + by (smt Finite_Cartesian_Product.transpose_transpose S True bezout_matrix_works2 ib + matrix_transpose_mul rel_simps(92) transpose_code transpose_row_code) + moreover have "S = A**Q" unfolding S Q by simp + ultimately show ?thesis by simp + next + case False + have Q: "Q = (Finite_Cartesian_Product.mat 1)" and S: "S = A" + using SQ False A00_A01 unfolding Smith_1x2_eucl_def by (auto simp add: Let_def) + show ?thesis using False A00_A01 S Q invertible_mat_1 by auto + qed +qed + + +(*Bezout_matrix in JNF*) +definition bezout_matrix_JNF :: "'a::comm_ring_1 mat \ nat \ nat \ nat + \ ('a \ 'a \ ('a \ 'a \ 'a \ 'a \ 'a)) \ 'a mat" + where + "bezout_matrix_JNF A a b j bezout = Matrix.mat (dim_row A) (dim_row A) (\(x,y). + (let + (p, q, u, v, d) = bezout (A $$ (a, j)) (A $$ (b, j)) + in + if x = a \ y = a then p else + if x = a \ y = b then q else + if x = b \ y = a then u else + if x = b \ y = b then v else + if x = y then 1 else 0))" + + +definition "Smith_1x2_eucl_JNF (A::'a::euclidean_ring_gcd mat) = ( + if A $$ (0, 0) = 0 \ A $$ (0, 1) \ 0 then + let Q = swaprows_mat 2 0 1; + A' = swapcols 0 1 A + in (A',Q) + else + if A $$ (0, 0) \ 0 \ A $$ (0, 1) \ 0 then + let bezout_matrix_right = transpose_mat (bezout_matrix_JNF (transpose_mat A) 0 1 0 euclid_ext2) + in (A * bezout_matrix_right, bezout_matrix_right) + else (A, 1\<^sub>m 2) + )" + + +lemma Smith_1x2_eucl_JNF_works: + assumes A: "A \ carrier_mat 1 2" + and SQ: "(S,Q) = Smith_1x2_eucl_JNF A" +shows "is_SNF A (1\<^sub>m 1, (Smith_1x2_eucl_JNF A))" +proof - + have i: "0 A $$ (0, 1) \ 0") + case True + have Q: "Q = swaprows_mat 2 0 1" + and S: "S = swapcols 0 1 A" + using SQ True unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def) + have S01: "S $$ (0,1) = 0" unfolding S using index_mat_swapcols j i True by simp + have dim_S: "S \ carrier_mat 1 2" using S A by auto + moreover have dim_Q: "Q \ carrier_mat 2 2" using S Q by auto + moreover have "invertible_mat Q" (*TODO: better a lemma for invertible swaprows_mat, etc*) + proof - + have "Determinant.det (swaprows_mat 2 0 1) = -1" by (rule det_swaprows_mat, auto) + also have "... dvd 1" by simp + finally show ?thesis using Q dim_Q invertible_iff_is_unit_JNF by blast + qed + moreover have "S = A * Q" unfolding S Q using A by (simp add: swapcols_mat) + moreover have "Smith_normal_form_mat S" unfolding Smith_normal_form_mat_def isDiagonal_mat_def + using S01 dim_S less_2_cases by fastforce + ultimately show ?thesis using SQ S Q A unfolding is_SNF_def by auto + next + case False note A00_A01 = False + show ?thesis + proof (cases "A $$ (0,0) \ 0 \ A $$ (0,1) \ 0") + case True + have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2) + let ?BM = "(bezout_matrix_JNF A\<^sup>T 0 1 0 euclid_ext2)\<^sup>T" + have Q: "Q = ?BM" and S: "S = A*?BM" + using SQ True A00_A01 unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def) + let ?a = "A $$ (0, 0)" let ?b = "A $$ (0, Suc 0)" + obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?b" by (metis prod_cases5) + have d: "p*?a + q*?b = d" and u: "u = - ?b div d" and v: "v = ?a div d" + using pquvd unfolding euclid_ext2_def using bezout_coefficients_fst_snd by blast+ + have da: "d dvd ?a" and db: "d dvd ?b" and gcd_ab: "d = gcd ?a ?b" + by (metis euclid_ext2_def gcd_dvd1 gcd_dvd2 pquvd prod.sel(2))+ + have dim_S: "S \ carrier_mat 1 2" using S A by (simp add: bezout_matrix_JNF_def) + moreover have dim_Q: "Q \ carrier_mat 2 2" using A Q by (simp add: bezout_matrix_JNF_def) + have "invertible_mat Q" + proof - + have "Determinant.det ?BM = ?BM $$ (0, 0) * ?BM $$ (1, 1) - ?BM $$ (0, 1) * ?BM $$ (1, 0)" + by (rule det_2, insert A, auto simp add: bezout_matrix_JNF_def) + also have "... = p * v - u*q" + by (insert i j pquvd, auto simp add: bezout_matrix_JNF_def, metis split_conv) + also have "... = (p * ?a) div d - (q * (-?b)) div d" unfolding v u + by (simp add: da db div_mult_swap mult.commute) + also have "... = (p * ?a + q * ?b) div d" + by (metis (no_types, lifting) da db diff_minus_eq_add div_diff dvd_minus_iff dvd_trans + dvd_triv_right more_arith_simps(8)) + also have "... = 1 " unfolding d using True da by fastforce + finally show ?thesis unfolding Q + by (metis (full_types) Determinant.det_def Q carrier_matI invertible_iff_is_unit_JNF + not_is_unit_0 one_dvd) + qed + moreover have S_AQ: "S = A*Q" unfolding S Q by simp + moreover have S01: "S $$ (0,1) = 0" + proof - + have Q01: "Q $$ (0, 1) = u" + proof - + have "?BM $$ (0,1) = (bezout_matrix_JNF A\<^sup>T 0 1 0 euclid_ext2) $$ (1, 0)" + using Q dim_Q by auto + also have "... = (\(x::nat, y::nat). + let (p, q, u, v, d) = euclid_ext2 (A\<^sup>T $$ (0, 0)) (A\<^sup>T $$ (1, 0)) in if x = 0 \ y = 0 then p + else if x = 0 \ y = 1 then q else if x = 1 \ y = 0 then u else if x = 1 \ y = 1 then v + else if x = y then 1 else 0) (1, 0)" + unfolding bezout_matrix_JNF_def by (rule index_mat(1), insert A, auto) + also have "... = u" using pquvd unfolding split_beta Let_def + by (auto, metis A One_nat_def carrier_matD(2) fst_conv i index_transpose_mat(1) + j rel_simps(51) snd_conv) + finally show ?thesis unfolding Q by auto + qed + have Q11: "Q $$ (1, 1) = v" + proof - + have "?BM $$ (1,1) = (bezout_matrix_JNF A\<^sup>T 0 1 0 euclid_ext2) $$ (1, 1)" + using Q dim_Q by auto + also have "... = (\(x::nat, y::nat). + let (p, q, u, v, d) = euclid_ext2 (A\<^sup>T $$ (0, 0)) (A\<^sup>T $$ (1, 0)) in if x = 0 \ y = 0 then p + else if x = 0 \ y = 1 then q else if x = 1 \ y = 0 then u else if x = 1 \ y = 1 then v + else if x = y then 1 else 0) (1, 1)" + unfolding bezout_matrix_JNF_def by (rule index_mat(1), insert A, auto) + also have "... = v" using pquvd unfolding split_beta Let_def + by (auto, metis A One_nat_def carrier_matD(2) fst_conv i index_transpose_mat(1) + j rel_simps(51) snd_conv) + finally show ?thesis unfolding Q by auto + qed + have "S $$ (0,1) = Matrix.row A 0 \ col Q 1" using index_mult_mat Q S dim_S i by auto + also have "... = (\i = 0..<2. Matrix.row A 0 $v i * Q $$ (i, 1))" + unfolding scalar_prod_def using dim_S dim_Q by auto + also have "... = (\i \ {0,1}. Matrix.row A 0 $v i * Q $$ (i, 1))" by (rule sum.cong, auto) + also have "... = Matrix.row A 0 $v 0 * Q $$ (0, 1) + Matrix.row A 0 $v 1 * Q $$ (1, 1)" + using sum_two_elements by auto + also have "... = ?a*u + ?b * v" unfolding Q01 Q11 using i index_row(1) j A by auto + also have "... = 0" unfolding u v + by (smt Groups.mult_ac(2) Groups.mult_ac(3) add.right_inverse add_uminus_conv_diff da db + diff_minus_eq_add dvd_div_mult_self dvd_neg_div minus_mult_left) + finally show ?thesis . + qed + moreover have "Smith_normal_form_mat S" + using less_2_cases S01 dim_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def + by fastforce + ultimately show ?thesis using S Q A SQ unfolding is_SNF_def bezout_matrix_JNF_def by force + next + case False + have Q: "Q = 1\<^sub>m 2" and S: "S = A" + using SQ False A00_A01 unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def) + have "is_SNF A (1\<^sub>m 1, A, 1\<^sub>m 2)" + by (rule is_SNF_intro, insert A False A00_A01 S Q A less_2_cases, + unfold Smith_normal_form_mat_def isDiagonal_mat_def, fastforce+) + thus ?thesis using SQ S Q by auto + qed + qed +qed + +subsection \The final executable algorithm to transform any matrix into its Smith normal form\ + +global_interpretation Smith_ED: Smith_Impl Smith_1x2_eucl_JNF Smith_2x2_JNF_eucl "(div)" + defines Smith_ED_1xn_aux = Smith_ED.Smith_1xn_aux + and Smith_ED_nx1 = Smith_ED.Smith_nx1 + and Smith_ED_1xn = Smith_ED.Smith_1xn + and Smith_ED_2xn = Smith_ED.Smith_2xn + and Smith_ED_nx2 = Smith_ED.Smith_nx2 + and Smith_ED_mxn = Smith_ED.Smith_mxn +proof + show "\(A::'a mat)\carrier_mat 1 2. is_SNF A (1\<^sub>m 1, Smith_1x2_eucl_JNF A)" + using Smith_1x2_eucl_JNF_works prod.collapse by blast + show "\A\carrier_mat 2 2. is_SNF A (Smith_2x2_JNF_eucl A)" + by (simp add: Smith_2x2_JNF_eucl_def Smith_2x2_JNF_eucl_works split_beta) + show "is_div_op ((div)::'a\'a\'a::euclidean_ring_gcd)" + by (unfold is_div_op_def, simp) +qed + + +(* +value[code] "let (P,S,Q) = diagonalize_2x2 ((list_of_list_to_matrix [[32,128],[24,20]])::int^2^2) + in (matrix_to_list_of_list P,matrix_to_list_of_list S,matrix_to_list_of_list Q)" +value [code] "show (diagonalize_2x2_JNF (mat_of_rows_list 2 [[1,2::int],[3,4]]))" +*) + + +(* +value [code] "show (Smith_ED_mxn (mat_of_rows_list 2 [[1,2::int],[3,4]]))" + +value [code] "show (Smith_ED_mxn (mat_of_rows_list 2 + [ + [[:2,4,1:]::rat poly, [:3,2,0,2:]], + [[:0,2:] , [:3,2:]] + ] +))" +*) + + +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/SNF_Algorithm_HOL_Analysis.thy b/thys/Smith_Normal_Form/SNF_Algorithm_HOL_Analysis.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Algorithm_HOL_Analysis.thy @@ -0,0 +1,161 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \The Smith normal form algorithm in HOL Analysis\ + +theory SNF_Algorithm_HOL_Analysis + imports + SNF_Algorithm + Admits_SNF_From_Diagonal_Iff_Bezout_Ring +begin + +subsection \Transferring the result from JNF to HOL Anaylsis\ + +(*Now, we transfer the algorithm to HMA and get the final lemma.*) + +definition Smith_mxn_HMA :: "(('a::comm_ring_1^2) \ (('a^2) \ ('a^2^2))) + \ (('a^2^2) \ (('a^2^2) \ ('a^2^2) \ ('a^2^2))) \ ('a\'a\'a) \ ('a^'n::mod_type^'m::mod_type) + \ (('a^'m::mod_type^'m::mod_type)\ ('a^'n::mod_type^'m::mod_type) \ ('a^'n::mod_type^'n::mod_type))" + where +"Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A = + (let Smith_1x2_JNF = (\A'. let (S',Q') = Smith_1x2 (Mod_Type_Connect.to_hma\<^sub>v (Matrix.row A' 0)) + in (mat_of_row (Mod_Type_Connect.from_hma\<^sub>v S'), Mod_Type_Connect.from_hma\<^sub>m Q')); + Smith_2x2_JNF = (\A'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hma\<^sub>m A') + in (Mod_Type_Connect.from_hma\<^sub>m P', Mod_Type_Connect.from_hma\<^sub>m S', Mod_Type_Connect.from_hma\<^sub>m Q')); + (P,S,Q) = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op (Mod_Type_Connect.from_hma\<^sub>m A) + in (Mod_Type_Connect.to_hma\<^sub>m P, Mod_Type_Connect.to_hma\<^sub>m S, Mod_Type_Connect.to_hma\<^sub>m Q) + )" + + +definition "is_SNF_HMA A R = (case R of (P,S,Q) \ + invertible P \ invertible Q + \ Smith_normal_form S \ S = P ** A ** Q)" + +subsection \Soundness in HOL Anaylsis\ + +lemma is_SNF_Smith_mxn_HMA: + fixes A::"'a::comm_ring_1 ^ 'n::mod_type ^ 'm::mod_type" + assumes PSQ: "(P,S,Q) = Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A" + and SNF_1x2_works: "\A. let (S',Q) = Smith_1x2 A in S' $h 1 = 0 \ invertible Q \ S' = A v* Q" + and SNF_2x2_works: "\A. is_SNF_HMA A (Smith_2x2 A)" + and d: "is_div_op div_op" + shows "is_SNF_HMA A (P,S,Q)" +proof - + let ?A = "Mod_Type_Connect.from_hma\<^sub>m A" + define Smith_1x2_JNF where "Smith_1x2_JNF = (\A'. let (S',Q') + = Smith_1x2 (Mod_Type_Connect.to_hma\<^sub>v (Matrix.row A' 0)) + in (mat_of_row (Mod_Type_Connect.from_hma\<^sub>v S'), Mod_Type_Connect.from_hma\<^sub>m Q'))" + define Smith_2x2_JNF where "Smith_2x2_JNF = (\A'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hma\<^sub>m A') + in (Mod_Type_Connect.from_hma\<^sub>m P', Mod_Type_Connect.from_hma\<^sub>m S', Mod_Type_Connect.from_hma\<^sub>m Q'))" + obtain P' S' Q' where P'S'Q': "(P',S',Q') = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A" + by (metis prod_cases3) + have PSQ_P'S'Q': "(P,S,Q) = + (Mod_Type_Connect.to_hma\<^sub>m P', Mod_Type_Connect.to_hma\<^sub>m S', Mod_Type_Connect.to_hma\<^sub>m Q')" + using PSQ P'S'Q' Smith_1x2_JNF_def Smith_2x2_JNF_def + unfolding Smith_mxn_HMA_def Let_def by (metis case_prod_conv) + have SNF_1x2_works': "\(A::'a mat) \ carrier_mat 1 2. is_SNF A (1\<^sub>m 1, (Smith_1x2_JNF A))" + proof (rule+) + fix A'::"'a mat" assume A': "A' \ carrier_mat 1 2" + let ?A' = "(Mod_Type_Connect.to_hma\<^sub>v (Matrix.row A' 0))::'a^2" + obtain S2 Q2 where S'Q': "(S2,Q2) = Smith_1x2 ?A'" + by (metis surjective_pairing) + let ?S2 = "(Mod_Type_Connect.from_hma\<^sub>v S2)" + let ?S' = "mat_of_row ?S2" + let ?Q' = "Mod_Type_Connect.from_hma\<^sub>m Q2" + have [transfer_rule]: "Mod_Type_Connect.HMA_V ?S2 S2" + unfolding Mod_Type_Connect.HMA_V_def by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q2" + unfolding Mod_Type_Connect.HMA_M_def by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 (1::2)" + unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1) + have c[transfer_rule]: "Mod_Type_Connect.HMA_V ((Matrix.row A' 0)) ?A'" + unfolding Mod_Type_Connect.HMA_V_def + by (rule from_hma_to_hma\<^sub>v[symmetric], insert A', auto simp add: Matrix.row_def) + have *: "Smith_1x2_JNF A' = (?S', ?Q')" by (metis Smith_1x2_JNF_def S'Q' case_prod_conv) + show "is_SNF A' (1\<^sub>m 1, Smith_1x2_JNF A')" unfolding * + proof (rule is_SNF_intro) + let ?row_A' = "(Matrix.row A' 0)" + have w: "S2 $h 1 = 0 \ invertible Q2 \ S2 = ?A' v* Q2" + using SNF_1x2_works by (metis (mono_tags, lifting) S'Q' fst_conv prod.case_eq_if snd_conv) + have "?S2 $v 1 = 0" using w[untransferred] by auto + thus "Smith_normal_form_mat ?S'" unfolding Smith_normal_form_mat_def isDiagonal_mat_def + by (auto simp add: less_2_cases_iff) + have S2_Q2_A: "S2 = transpose Q2 *v ?A'" using w transpose_matrix_vector by auto + have S2_Q2_A': "?S2 = transpose_mat ?Q' *\<^sub>v ((Matrix.row A' 0))" using S2_Q2_A by transfer' + show "1\<^sub>m 1 \ carrier_mat (dim_row A') (dim_row A')" using A' by auto + show "?Q' \ carrier_mat (dim_col A') (dim_col A')" using A' by auto + show "invertible_mat (1\<^sub>m 1)" by auto + show "invertible_mat ?Q'" using w[untransferred] by auto + have "?S' = A' * ?Q'" + proof (rule eq_matI) + show "dim_row ?S' = dim_row (A' * ?Q')" and "dim_col ?S' = dim_col (A' * ?Q')" + using A' by auto + fix i j assume i: "i < dim_row (A' * ?Q')" and j: "j < dim_col (A' * ?Q')" + have "?S' $$ (i, j) = ?S' $$ (0, j)" + by (metis A' One_nat_def carrier_matD(1) i index_mult_mat(2) less_Suc0) + also have "... =?S2 $v j" using j by auto + also have "... = (transpose_mat ?Q' *\<^sub>v ?row_A') $v j" unfolding S2_Q2_A' by simp + also have "... = Matrix.row (transpose_mat ?Q') j \ ?row_A'" + by (rule index_mult_mat_vec, insert j, auto) + also have "... = Matrix.col ?Q' j \ ?row_A'" using j by auto + also have "... = ?row_A' \ Matrix.col ?Q' j" + by (metis (no_types, lifting) Mod_Type_Connect.HMA_V_def Mod_Type_Connect.from_hma\<^sub>m_def + Mod_Type_Connect.from_hma\<^sub>v_def c col_def comm_scalar_prod dim_row_mat(1) vec_carrier) + also have "... = (A' * ?Q') $$ (0, j)" using A' j by auto + finally show "?S' $$ (i, j) = (A' * ?Q') $$ (i, j)" using i j A' by auto + qed + thus "?S' = 1\<^sub>m 1 * A' * ?Q'" using A' by auto + qed + qed + have SNF_2x2_works': "\(A::'a mat) \ carrier_mat 2 2. is_SNF A (Smith_2x2_JNF A)" + proof + fix A'::"'a mat" assume A': "A' \ carrier_mat 2 2" + let ?A' = "Mod_Type_Connect.to_hma\<^sub>m A'::'a^2^2" + obtain P2 S2 Q2 where P2S2Q2: "(P2, S2, Q2) = Smith_2x2 ?A'" + by (metis prod_cases3) + let ?P2 = "Mod_Type_Connect.from_hma\<^sub>m P2" + let ?S2 = "Mod_Type_Connect.from_hma\<^sub>m S2" + let ?Q2 = "Mod_Type_Connect.from_hma\<^sub>m Q2" + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q2 Q2" + and [transfer_rule]: "Mod_Type_Connect.HMA_M ?P2 P2" + and [transfer_rule]: "Mod_Type_Connect.HMA_M ?S2 S2" + and [transfer_rule]: "Mod_Type_Connect.HMA_M A' ?A'" + unfolding Mod_Type_Connect.HMA_M_def using A' by auto + have "is_SNF A' (?P2,?S2,?Q2)" + proof - + have P2: "?P2 \ carrier_mat (dim_row A') (dim_row A')" and + Q2: "?Q2 \ carrier_mat (dim_col A') (dim_col A')" using A' by auto + have "is_SNF_HMA ?A' (P2,S2,Q2)" using SNF_2x2_works by (simp add: P2S2Q2) + hence "invertible P2 \ invertible Q2 \ Smith_normal_form S2 \ S2 = P2 ** ?A' ** Q2" + unfolding is_SNF_HMA_def by auto + from this[untransferred] show ?thesis using P2 Q2 unfolding is_SNF_def by auto + qed + thus "is_SNF A' (Smith_2x2_JNF A')" using P2S2Q2 by (metis Smith_2x2_JNF_def case_prod_conv) + qed + interpret Smith_Impl Smith_1x2_JNF Smith_2x2_JNF div_op + using SNF_2x2_works' SNF_1x2_works' d by (unfold_locales, auto) + have A: "?A \ carrier_mat CARD('m) CARD('n)" by auto + have "is_SNF ?A (Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A)" + by (rule is_SNF_Smith_mxn[OF A]) + hence inv_P': "invertible_mat P'" + and Smith_S': "Smith_normal_form_mat S'" and inv_Q': "invertible_mat Q'" + and S'_P'AQ': "S' = P' * ?A * Q'" + and P': "P' \ carrier_mat (dim_row ?A) (dim_row ?A)" + and Q': "Q' \ carrier_mat (dim_col ?A) (dim_col ?A)" + unfolding is_SNF_def P'S'Q'[symmetric] by auto + have S': "S' \ carrier_mat (dim_row ?A) (dim_col ?A)" using P' Q' S'_P'AQ' by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_M P' P" + and [transfer_rule]: "Mod_Type_Connect.HMA_M S' S" + and [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q" + and [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A" + unfolding Mod_Type_Connect.HMA_M_def using PSQ_P'S'Q' + using from_hma_to_hma\<^sub>m[symmetric] P' A Q' S' by auto + have inv_Q: "invertible Q" using inv_Q' by transfer + moreover have Smith_S: "Smith_normal_form S" using Smith_S' by transfer + moreover have inv_P: "invertible P" using inv_P' by transfer + moreover have "S = P ** A ** Q" using S'_P'AQ' by transfer + thus ?thesis using inv_Q inv_P Smith_S unfolding is_SNF_HMA_def by auto +qed +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/SNF_Algorithm_Two_Steps.thy b/thys/Smith_Normal_Form/SNF_Algorithm_Two_Steps.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Algorithm_Two_Steps.thy @@ -0,0 +1,62 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Smith normal form algorithm based on two steps in HOL Analysis\ + +theory SNF_Algorithm_Two_Steps + imports Diagonalize +begin + + +text \This file contains an algorithm to transform a matrix to its Smith normal form, based +on two steps: first it is converted into a diagonal matrix and then transformed from diagonal +to Smith. + +We assume the existence of a diagonalize operation, and then we just have to connect it to the +existing algorithm (in HOL Analysis) to transform a diagonal matrix into its Smith normal form. +\ + +subsection \The implementation\ + +context diagonalize +begin + +definition "Smith_normal_form_of A bezout = ( + let (P'',D,Q'') = diagonalize A bezout; + (P',S,Q') = diagonal_to_Smith_PQ D bezout + in (P'**P'',S,Q''**Q') + )" + +subsection \Soundness in HOL Analysis\ + +lemma Smith_normal_form_of_soundness: + fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}" + assumes b: "is_bezout_ext bezout" + assumes PSQ: "(P,S,Q) = Smith_normal_form_of A bezout" + shows "S = P**A**Q \ invertible P \ invertible Q \ Smith_normal_form S" +proof - + obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize A bezout" + by (metis prod_cases3) + have 1: "invertible P'' \ invertible Q'' \ isDiagonal D \ D = P''**A**Q''" + by (rule soundness_diagonalize[OF b PDQ_diag[symmetric]]) + obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ D bezout" + using PSQ PDQ_diag unfolding Smith_normal_form_of_def + unfolding Let_def by (smt Pair_inject case_prod_beta' surjective_pairing) + have 2: "invertible P' \ invertible Q' \ Smith_normal_form S \ S = P'**D**Q'" + using diagonal_to_Smith_PQ' 1 b PSQ_D by blast + have P: "P = P'**P''" + by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject + Smith_normal_form_of_def PSQ old.prod.case) + have Q: "Q = Q''**Q'" + by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject + Smith_normal_form_of_def PSQ old.prod.case) + have "S = P**A**Q" using 1 2 by (simp add: P Q matrix_mul_assoc) + moreover have "invertible P" using P by (simp add: 1 2 invertible_mult) + moreover have "invertible Q" using Q by (simp add: 1 2 invertible_mult) + ultimately show ?thesis using 2 by auto +qed + +end +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/SNF_Algorithm_Two_Steps_JNF.thy b/thys/Smith_Normal_Form/SNF_Algorithm_Two_Steps_JNF.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Algorithm_Two_Steps_JNF.thy @@ -0,0 +1,59 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Smith normal form algorithm based on two steps in JNF\ + +theory SNF_Algorithm_Two_Steps_JNF + imports + Diagonalize + Diagonal_To_Smith_JNF +begin + +subsection \Moving the result from HOL Analysis to JNF\ +context diagonalize +begin + +definition "Smith_normal_form_of_JNF A bezout = ( + let (P'',D,Q'') = diagonalize_JNF A bezout; + (P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout + in (P'*P'',S,Q''*Q') + )" + +(*Soundness theorem in the JNF library*) + +lemma Smith_normal_form_of_JNF_soundness: + assumes b: "is_bezout_ext bezout" and A: "A \ carrier_mat m n" + and n: "1 < n" and m: "1 < m" (*Same as previously, those assumptions arose from the requirements +of mod_type. They could be dropped proving them as particular cases*) + and PSQ: "Smith_normal_form_of_JNF A bezout = (P,S,Q)" +shows "S = P*A*Q \ invertible_mat P \ invertible_mat Q \ Smith_normal_form_mat S + \ P \ carrier_mat m m \ S \ carrier_mat m n \ Q\ carrier_mat n n" +proof - + obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize_JNF A bezout" + by (metis prod_cases3) + have 1: "invertible_mat P'' \ invertible_mat Q'' \ isDiagonal_mat D \ D = P''*A*Q'' + \ P'' \ carrier_mat m m \ Q'' \ carrier_mat n n \ D \ carrier_mat m n" + using soundness_diagonalize_JNF'[OF b A PDQ_diag[symmetric]] by auto + obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout" + using PSQ PDQ_diag unfolding Smith_normal_form_of_JNF_def Let_def split_beta + by (metis Pair_inject prod.collapse) + have 2: "invertible_mat P' \ invertible_mat Q' \ Smith_normal_form_mat S \ S = P'*D*Q' + \ P' \ carrier_mat m m \ Q' \ carrier_mat n n \ S \ carrier_mat m n" + using diagonal_to_Smith_PQ_JNF[OF _ b _ PSQ_D n m] 1 n m by auto + have P: "P = P'*P''" + by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def fst_conv prod.simps(2)) + have Q: "Q = Q''*Q'" + by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def snd_conv prod.simps(2)) + have "S = P'*(P''*A*Q'')*Q'" using 1 2 by auto + also have "... = (P'*P'')*A*(Q''*Q')" + by (smt "1" "2" A assoc_mult_mat carrier_matD carrier_mat_triv index_mult_mat) + finally have "S = (P' * P'') * A * (Q'' * Q')" . + moreover have "invertible_mat P" unfolding P by (rule invertible_mult_JNF, insert 1 2, auto) + moreover have "invertible_mat Q" unfolding Q by (rule invertible_mult_JNF, insert 1 2, auto) + ultimately show ?thesis using 1 2 P Q by auto +qed + +end +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy b/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy @@ -0,0 +1,1168 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Missing results\ + +theory SNF_Missing_Lemmas + imports + Hermite.Hermite + Mod_Type_Connect + Jordan_Normal_Form.DL_Rank_Submatrix + "List-Index.List_Index" +begin + +text \This theory presents some missing lemmas that are required for the Smith normal form +development. Some of them could be added to different AFP entries, such as the Jordan Normal +Form AFP entry by Ren\'e Thiemann and Akihisa Yamada. + +However, not all the lemmas can be added directly, since some imports are required.\ + +hide_const (open) C +hide_const (open) measure + +subsection \Miscellaneous lemmas\ + +lemma sum_two_rw: "(\i = 0..<2. f i) = (\i \ {0,1::nat}. f i)" + by (rule sum.cong, auto) + +lemma sum_common_left: + fixes f::"'a \ 'b::comm_ring_1" + assumes "finite A" + shows "sum (\i. c * f i) A = c * sum f A" + by (simp add: mult_hom.hom_sum) + +lemma prod3_intro: + assumes "fst A = a" and "fst (snd A) = b" and "snd (snd A) = c" + shows "A = (a,b,c)" using assms by auto + + +subsection \Transfer rules for the HMA\_Connect file of the Perron-Frobenius development\ + +hide_const (open) HMA_M HMA_I to_hma\<^sub>m from_hma\<^sub>m +hide_fact (open) from_hma\<^sub>m_def from_hma_to_hma\<^sub>m HMA_M_def HMA_I_def dim_row_transfer_rule + dim_col_transfer_rule + +context + includes lifting_syntax +begin + +lemma HMA_invertible_matrix[transfer_rule]: + "((HMA_Connect.HMA_M :: _ \ 'a :: comm_ring_1 ^ 'n ^ 'n \ _) ===> (=)) invertible_mat invertible" +proof (intro rel_funI, goal_cases) + case (1 x y) + note rel_xy[transfer_rule] = "1" + have eq_dim: "dim_col x = dim_row x" + using HMA_Connect.dim_col_transfer_rule HMA_Connect.dim_row_transfer_rule rel_xy + by fastforce + moreover have "\A'. y ** A' = Finite_Cartesian_Product.mat 1 \ A' ** y = Finite_Cartesian_Product.mat 1" + if xB: "x * B = 1\<^sub>m (dim_row x)" and Bx: "B * x = 1\<^sub>m (dim_row B)" for B + proof - + let ?A' = "HMA_Connect.to_hma\<^sub>m B:: 'a :: comm_ring_1 ^ 'n ^ 'n" + have rel_BA[transfer_rule]: "HMA_M B ?A'" + by (metis (no_types, lifting) Bx HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1) + from_hma\<^sub>m_def from_hma_to_hma\<^sub>m index_mult_mat(3) index_one_mat(3) rel_xy xB) + have [simp]: "dim_row B = CARD('n)" using dim_row_transfer_rule rel_BA by blast + have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast + have "y ** ?A' = Finite_Cartesian_Product.mat 1" using xB by (transfer, simp) + moreover have "?A' ** y = Finite_Cartesian_Product.mat 1" using Bx by (transfer, simp) + ultimately show ?thesis by blast + qed + moreover have "\B. x * B = 1\<^sub>m (dim_row x) \ B * x = 1\<^sub>m (dim_row B)" + if yA: "y ** A' = Finite_Cartesian_Product.mat 1" and Ay: "A' ** y = Finite_Cartesian_Product.mat 1" for A' + proof - + let ?B = "(from_hma\<^sub>m A')" + have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast + have [transfer_rule]: "HMA_M ?B A'" by (simp add: HMA_M_def) + hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto + have "x * ?B = 1\<^sub>m (dim_row x)" using yA by (transfer', auto) + moreover have "?B * x = 1\<^sub>m (dim_row ?B)" using Ay by (transfer', auto) + ultimately show ?thesis by auto + qed + ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto +qed +end + +subsection \Lemmas obtained from HOL Analysis using local type definitions\ + +thm Cartesian_Space.invertible_mult (*In HOL Analysis*) +thm invertible_iff_is_unit (*In HOL Analysis*) +thm det_non_zero_imp_unit (*In JNF, but only for fields*) +thm mat_mult_left_right_inverse (*In JNF, but only for fields*) + +lemma invertible_mat_zero: + assumes A: "A \ carrier_mat 0 0" + shows "invertible_mat A" + using A unfolding invertible_mat_def inverts_mat_def one_mat_def times_mat_def scalar_prod_def + Matrix.row_def col_def carrier_mat_def + by (auto, metis (no_types, lifting) cong_mat not_less_zero) + +lemma invertible_mult_JNF: + fixes A::"'a::comm_ring_1 mat" + assumes A: "A\carrier_mat n n" and B: "B\carrier_mat n n" + and inv_A: "invertible_mat A" and inv_B: "invertible_mat B" +shows "invertible_mat (A*B)" +proof (cases "n = 0") + case True + then show ?thesis using assms + by (simp add: invertible_mat_zero) +next + case False + then show ?thesis using + invertible_mult[where ?'a="'a::comm_ring_1", where ?'b="'n::finite", where ?'c="'n::finite", + where ?'d="'n::finite", untransferred, cancel_card_constraint, OF assms] by auto +qed + +lemma invertible_iff_is_unit_JNF: + assumes A: "A \ carrier_mat n n" + shows "invertible_mat A \ (Determinant.det A) dvd 1" +proof (cases "n=0") + case True + then show ?thesis using det_dim_zero invertible_mat_zero A by auto +next + case False + then show ?thesis using invertible_iff_is_unit[untransferred, cancel_card_constraint] A by auto +qed + + +subsection \Lemmas about matrices, submatrices and determinants\ + +(*This is a generalization of thm mat_mult_left_right_inverse*) +thm mat_mult_left_right_inverse +lemma mat_mult_left_right_inverse: + fixes A :: "'a::comm_ring_1 mat" + assumes A: "A \ carrier_mat n n" + and B: "B \ carrier_mat n n" and AB: "A * B = 1\<^sub>m n" + shows "B * A = 1\<^sub>m n" +proof - + have "Determinant.det (A * B) = Determinant.det (1\<^sub>m n)" using AB by auto + hence "Determinant.det A * Determinant.det B = 1" + using Determinant.det_mult[OF A B] det_one by auto + hence det_A: "(Determinant.det A) dvd 1" and det_B: "(Determinant.det B) dvd 1" + using dvd_triv_left dvd_triv_right by metis+ + hence inv_A: "invertible_mat A" and inv_B: "invertible_mat B" + using A B invertible_iff_is_unit_JNF by blast+ + obtain B' where inv_BB': "inverts_mat B B'" and inv_B'B: "inverts_mat B' B" + using inv_B unfolding invertible_mat_def by auto + have B'_carrier: "B' \ carrier_mat n n" + by (metis B inv_B'B inv_BB' carrier_matD(1) carrier_matD(2) carrier_mat_triv + index_mult_mat(3) index_one_mat(3) inverts_mat_def) + have "B * A * B = B" using A AB B by auto + hence "B * A * (B * B') = B * B'" + by (smt A AB B B'_carrier assoc_mult_mat carrier_matD(1) inv_BB' inverts_mat_def one_carrier_mat) + thus ?thesis + by (metis A B carrier_matD(1) carrier_matD(2) index_mult_mat(3) inv_BB' + inverts_mat_def right_mult_one_mat') +qed + +context comm_ring_1 +begin + +lemma col_submatrix_UNIV: +assumes "j < card {i. i < dim_col A \ i \ J}" +shows "col (submatrix A UNIV J) j = col A (pick J j)" +proof (rule eq_vecI) + show dim_eq:"dim_vec (col (submatrix A UNIV J) j) = dim_vec (col A (pick J j))" + by (simp add: dim_submatrix(1)) + fix i assume "i < dim_vec (col A (pick J j))" + show "col (submatrix A UNIV J) j $v i = col A (pick J j) $v i" + by (smt Collect_cong assms col_def dim_col dim_eq dim_submatrix(1) + eq_vecI index_vec pick_UNIV submatrix_index) +qed + +lemma submatrix_split2: "submatrix A I J = submatrix (submatrix A I UNIV) UNIV J" (is "?lhs = ?rhs") +proof (rule eq_matI) + show dr: "dim_row ?lhs = dim_row ?rhs" + by (simp add: dim_submatrix(1)) + show dc: "dim_col ?lhs = dim_col ?rhs" + by (simp add: dim_submatrix(2)) + fix i j assume i: "i < dim_row ?rhs" + and j: "j < dim_col ?rhs" + have "?rhs $$ (i, j) = (submatrix A I UNIV) $$ (pick UNIV i, pick J j)" + proof (rule submatrix_index) + show "i < card {i. i < dim_row (submatrix A I UNIV) \ i \ UNIV}" + by (metis (full_types) dim_submatrix(1) i) + show "j < card {j. j < dim_col (submatrix A I UNIV) \ j \ J}" + by (metis (full_types) dim_submatrix(2) j) + qed + also have "... = A $$ (pick I (pick UNIV i), pick UNIV (pick J j))" + proof (rule submatrix_index) + show "pick UNIV i < card {i. i < dim_row A \ i \ I}" + by (metis (full_types) dr dim_submatrix(1) i pick_UNIV) + show "pick J j < card {j. j < dim_col A \ j \ UNIV}" + by (metis (full_types) dim_submatrix(2) j pick_le) + qed + also have "... = ?lhs $$ (i,j)" + proof (unfold pick_UNIV, rule submatrix_index[symmetric]) + show "i < card {i. i < dim_row A \ i \ I}" + by (metis (full_types) dim_submatrix(1) dr i) + show "j < card {j. j < dim_col A \ j \ J}" + by (metis (full_types) dim_submatrix(2) dc j) + qed + finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .. +qed + +lemma submatrix_mult: + "submatrix (A*B) I J = submatrix A I UNIV * submatrix B UNIV J" (is "?lhs = ?rhs") +proof (rule eq_matI) + show "dim_row ?lhs = dim_row ?rhs" unfolding submatrix_def by auto + show "dim_col ?lhs = dim_col ?rhs" unfolding submatrix_def by auto + fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs" + have i1: "i < card {i. i < dim_row (A * B) \ i \ I}" + by (metis (full_types) dim_submatrix(1) i index_mult_mat(2)) + have j1: "j < card {j. j < dim_col (A * B) \ j \ J}" + by (metis dim_submatrix(2) index_mult_mat(3) j) + have pi: "pick I i < dim_row A" using i1 pick_le by auto + have pj: "pick J j < dim_col B" using j1 pick_le by auto + have row_rw: "Matrix.row (submatrix A I UNIV) i = Matrix.row A (pick I i)" + using i1 row_submatrix_UNIV by auto + have col_rw: "col (submatrix B UNIV J) j = col B (pick J j)" using j1 col_submatrix_UNIV by auto + have "?lhs $$ (i,j) = (A*B) $$ (pick I i, pick J j)" by (rule submatrix_index[OF i1 j1]) + also have "... = Matrix.row A (pick I i) \ col B (pick J j)" by (rule index_mult_mat(1)[OF pi pj]) + also have "... = Matrix.row (submatrix A I UNIV) i \ col (submatrix B UNIV J) j" + using row_rw col_rw by simp + also have "... = (?rhs) $$ (i,j)" by (rule index_mult_mat[symmetric], insert i j, auto) + finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" . +qed + +lemma det_singleton: + assumes A: "A \ carrier_mat 1 1" + shows "det A = A $$ (0,0)" + using A unfolding carrier_mat_def Determinant.det_def by auto + +lemma submatrix_singleton_index: + assumes A: "A \ carrier_mat n m" + and an: "a < n" and bm: "b < m" + shows "submatrix A {a} {b} $$ (0,0) = A $$ (a,b)" +proof - + have a: "{i. i = a \ i < dim_row A} = {a}" using an A unfolding carrier_mat_def by auto + have b: "{i. i = b \ i < dim_col A} = {b}" using bm A unfolding carrier_mat_def by auto + have "submatrix A {a} {b} $$ (0,0) = A $$ (pick {a} 0,pick {b} 0)" + by (rule submatrix_index, insert a b, auto) + moreover have "pick {a} 0 = a" by (auto, metis (full_types) LeastI) + moreover have "pick {b} 0 = b" by (auto, metis (full_types) LeastI) + ultimately show ?thesis by simp +qed +end + +lemma det_not_inj_on: + assumes not_inj_on: "\ inj_on f {0..r n n (\i. Matrix.row B (f i))) = 0" +proof - + obtain i j where i: "ij" + using not_inj_on unfolding inj_on_def by auto + show ?thesis + proof (rule det_identical_rows[OF _ ij i j]) + let ?B="(mat\<^sub>r n n (\i. row B (f i)))" + show "row ?B i = row ?B j" + proof (rule eq_vecI, auto) + fix ia assume ia: "ia < n" + have "row ?B i $ ia = ?B $$ (i, ia)" by (rule index_row(1), insert i ia, auto) + also have "... = ?B $$ (j, ia)" by (simp add: fi_fj i ia j) + also have "... = row ?B j $ ia" by (rule index_row(1)[symmetric], insert j ia, auto) + finally show "row ?B i $ ia = row (mat\<^sub>r n n (\i. row B (f i))) j $ ia" by simp + qed + show "mat\<^sub>r n n (\i. Matrix.row B (f i)) \ carrier_mat n n" by auto + qed +qed + + + +lemma mat_row_transpose: "(mat\<^sub>r nr nc f)\<^sup>T = mat nc nr (\(i,j). vec_index (f j) i)" + by (rule eq_matI, auto) + + +lemma obtain_inverse_matrix: + assumes A: "A \ carrier_mat n n" and i: "invertible_mat A" + obtains B where "inverts_mat A B" and "inverts_mat B A" and "B \ carrier_mat n n" +proof - + have "(\B. inverts_mat A B \ inverts_mat B A)" using i unfolding invertible_mat_def by auto + from this obtain B where AB: "inverts_mat A B" and BA: "inverts_mat B A" by auto + moreover have "B \ carrier_mat n n" using A AB BA unfolding carrier_mat_def inverts_mat_def + by (auto, metis index_mult_mat(3) index_one_mat(3))+ + ultimately show ?thesis using that by blast +qed + + +lemma invertible_mat_smult_mat: + fixes A :: "'a::comm_ring_1 mat" + assumes inv_A: "invertible_mat A" and k: "k dvd 1" + shows "invertible_mat (k \\<^sub>m A)" +proof - + obtain n where A: "A \ carrier_mat n n" using inv_A unfolding invertible_mat_def by auto + have det_dvd_1: "Determinant.det A dvd 1" using inv_A invertible_iff_is_unit_JNF[OF A] by auto + have "Determinant.det (k \\<^sub>m A) = k ^ dim_col A * Determinant.det A" by simp + also have "... dvd 1" by (rule unit_prod, insert k det_dvd_1 dvd_power_same, force+) + finally show ?thesis using invertible_iff_is_unit_JNF by (metis A smult_carrier_mat) +qed + +lemma invertible_mat_one[simp]: "invertible_mat (1\<^sub>m n)" + unfolding invertible_mat_def using inverts_mat_def by fastforce + +lemma four_block_mat_dim0: + assumes A: "A \ carrier_mat n n" + and B: "B \ carrier_mat n 0" + and C: "C \ carrier_mat 0 n" + and D: "D \ carrier_mat 0 0" +shows "four_block_mat A B C D = A" + unfolding four_block_mat_def using assms by auto + + +lemma det_four_block_mat_lower_right_id: + assumes A: "A \ carrier_mat m m" +and B: "B = 0\<^sub>m m (n-m)" +and C: "C = 0\<^sub>m (n-m) m" +and D: "D = 1\<^sub>m (n-m)" +and "n>m" +shows "Determinant.det (four_block_mat A B C D) = Determinant.det A" + using assms +proof (induct n arbitrary: A B C D) + case 0 + then show ?case by auto +next + case (Suc n) + let ?block = "(four_block_mat A B C D)" + let ?B = "Matrix.mat m (n-m) (\(i,j). 0)" + let ?C = "Matrix.mat (n-m) m (\(i,j). 0)" + let ?D = "1\<^sub>m (n-m)" + have mat_eq: "(mat_delete ?block n n) = four_block_mat A ?B ?C ?D" (is "?lhs = ?rhs") + proof (rule eq_matI) + fix i j assume i: "i < dim_row (four_block_mat A ?B ?C ?D)" + and j: "j < dim_col (four_block_mat A ?B ?C ?D)" + let ?f = " (if i < dim_row A then if j < dim_col A then A $$ (i, j) else B $$ (i, j - dim_col A) + else if j < dim_col A then C $$ (i - dim_row A, j) else D $$ (i - dim_row A, j - dim_col A))" + let ?g = "(if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?B $$ (i, j - dim_col A) + else if j < dim_col A then ?C $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))" + have "(mat_delete ?block n n) $$ (i,j) = ?block $$ (i,j)" + using i j Suc.prems unfolding mat_delete_def by auto + also have "... = ?f" + by (rule index_mat_four_block, insert Suc.prems i j, auto) + also have "... = ?g" using i j Suc.prems by auto + also have "... = four_block_mat A ?B ?C ?D $$ (i,j)" + by (rule index_mat_four_block[symmetric], insert Suc.prems i j, auto) + finally show "?lhs $$ (i,j) = ?rhs $$ (i,j)" . + qed (insert Suc.prems, auto) + have nn_1: "?block $$ (n, n) = 1" using Suc.prems by auto + have rw0: "(\i {..ii carrier_mat 1 n" + and B: "B \ carrier_mat m n" + and m0: "m \ 0" + and r: "Matrix.row A 0 = Matrix.row B 0" +shows "Matrix.row (A * V) 0 = Matrix.row (B * V) 0" +proof (rule eq_vecI) + show "dim_vec (Matrix.row (A * V) 0) = dim_vec (Matrix.row (B * V) 0)" using A B r by auto + fix i assume i: "i < dim_vec (Matrix.row (B * V) 0)" + have "Matrix.row (A * V) 0 $v i = (A * V) $$ (0,i)" by (rule index_row, insert i A, auto) + also have "... = Matrix.row A 0 \ col V i" by (rule index_mult_mat, insert A i, auto) + also have "... = Matrix.row B 0 \ col V i" using r by auto + also have "... = (B * V) $$ (0,i)" by (rule index_mult_mat[symmetric], insert m0 B i, auto) + also have "... = Matrix.row (B * V) 0 $v i" by (rule index_row[symmetric], insert i B m0, auto) + finally show "Matrix.row (A * V) 0 $v i = Matrix.row (B * V) 0 $v i" . +qed + + +lemma smult_mat_mat_one_element: + assumes A: "A \ carrier_mat 1 1" and B: "B \ carrier_mat 1 n" + shows "A * B = A $$ (0,0) \\<^sub>m B" +proof (rule eq_matI) + fix i j assume i: "i < dim_row (A $$ (0, 0) \\<^sub>m B)" and j: "j < dim_col (A $$ (0, 0) \\<^sub>m B)" + have i0: "i = 0" using A B i by auto + have "(A * B) $$ (i, j) = Matrix.row A i \ col B j" + by (rule index_mult_mat, insert i j A B, auto) + also have "... = Matrix.row A i $v 0 * col B j $v 0" unfolding scalar_prod_def using B by auto + also have "... = A$$(i,i) * B$$(i,j)" using A i i0 j by auto + also have "... = (A $$ (i, i) \\<^sub>m B) $$ (i, j)" + unfolding i by (rule index_smult_mat[symmetric], insert i j B, auto) + finally show "(A * B) $$ (i, j) = (A $$ (0, 0) \\<^sub>m B) $$ (i, j)" using i0 by simp +qed (insert A B, auto) + +lemma determinant_one_element: + assumes A: "A \ carrier_mat 1 1" shows "Determinant.det A = A $$ (0,0)" +proof - + have "Determinant.det A = prod_list (diag_mat A)" + by (rule det_upper_triangular[OF _ A], insert A, unfold upper_triangular_def, auto) + also have "... = A $$ (0,0)" using A unfolding diag_mat_def by auto + finally show ?thesis . +qed + + + +lemma invertible_mat_transpose: + assumes inv_A: "invertible_mat (A::'a::comm_ring_1 mat)" + shows "invertible_mat A\<^sup>T" +proof - + obtain n where A: "A \ carrier_mat n n" + using inv_A unfolding invertible_mat_def square_mat.simps by auto + hence At: "A\<^sup>T \ carrier_mat n n" by simp + have "Determinant.det A\<^sup>T = Determinant.det A" + by (metis Determinant.det_def Determinant.det_transpose carrier_matI + index_transpose_mat(2) index_transpose_mat(3)) + also have "... dvd 1" using invertible_iff_is_unit_JNF[OF A] inv_A by simp + finally show ?thesis using invertible_iff_is_unit_JNF[OF At] by auto +qed + +lemma dvd_elements_mult_matrix_left: + assumes A: "(A::'a::comm_ring_1 mat) \ carrier_mat m n" + and P: "P \ carrier_mat m m" + and x: "(\i j. i j x dvd A$$(i,j))" + shows "(\i j. i j x dvd (P*A)$$(i,j))" +proof - + have "x dvd (P * A) $$ (i, j)" if i: "i < m" and j: "j < n" for i j + proof - + have "(P * A) $$ (i, j) = (\ia = 0..ia = 0.. carrier_mat m n" + and Q: "Q \ carrier_mat n n" + and x: "(\i j. i j x dvd A$$(i,j))" + shows "(\i j. i j x dvd (A*Q)$$(i,j))" +proof - + have "x dvd (A*Q) $$ (i, j)" if i: "i < m" and j: "j < n" for i j + proof - + have "(A*Q) $$ (i, j) = (\ia = 0..ia = 0.. carrier_mat m n" + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and x: "(\i j. i j x dvd A$$(i,j))" +shows "(\i j. i j x dvd (P*A*Q)$$(i,j))" + using dvd_elements_mult_matrix_left[OF A P x] + by (meson P A Q dvd_elements_mult_matrix_right mult_carrier_mat) + + +definition append_cols :: "'a :: zero mat \ 'a mat \ 'a mat" (infixr "@\<^sub>c" 65)where + "A @\<^sub>c B = four_block_mat A B (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col B))" + +lemma append_cols_carrier[simp,intro]: + "A \ carrier_mat n a \ B \ carrier_mat n b \ (A @\<^sub>c B) \ carrier_mat n (a+b)" + unfolding append_cols_def by auto + +lemma append_cols_mult_left: + assumes A: "A \ carrier_mat n a" + and B: "B \ carrier_mat n b" + and P: "P \ carrier_mat n n" +shows "P * (A @\<^sub>c B) = (P*A) @\<^sub>c (P*B)" +proof - + let ?P = "four_block_mat P (0\<^sub>m n 0) (0\<^sub>m 0 n) (0\<^sub>m 0 0)" + have "P = ?P" by (rule eq_matI, auto) + hence "P * (A @\<^sub>c B) = ?P * (A @\<^sub>c B)" by simp + also have "?P * (A @\<^sub>c B) = four_block_mat (P * A + 0\<^sub>m n 0 * 0\<^sub>m 0 (dim_col A)) + (P * B + 0\<^sub>m n 0 * 0\<^sub>m 0 (dim_col B)) (0\<^sub>m 0 n * A + 0\<^sub>m 0 0 * 0\<^sub>m 0 (dim_col A)) + (0\<^sub>m 0 n * B + 0\<^sub>m 0 0 * 0\<^sub>m 0 (dim_col B))" unfolding append_cols_def + by (rule mult_four_block_mat, insert A B P, auto) + also have "... = four_block_mat (P * A) (P * B) (0\<^sub>m 0 (dim_col (P*A))) (0\<^sub>m 0 (dim_col (P*B)))" + by (rule cong_four_block_mat, insert P, auto) + also have "... = (P*A) @\<^sub>c (P*B)" unfolding append_cols_def by auto + finally show ?thesis . +qed + +lemma append_cols_mult_right_id: + assumes A: "(A::'a::semiring_1 mat) \ carrier_mat n 1" + and B: "B \ carrier_mat n (m-1)" + and C: "C = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D" + and D: "D \ carrier_mat (m-1) (m-1)" +shows "(A @\<^sub>c B) * C = A @\<^sub>c (B * D)" +proof - + let ?C = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D" + have "(A @\<^sub>c B) * C = (A @\<^sub>c B) * ?C" unfolding C by auto + also have "... = four_block_mat A B (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col B)) * ?C" + unfolding append_cols_def by auto + also have "... = four_block_mat (A * 1\<^sub>m 1 + B * 0\<^sub>m (m - 1) 1) (A * 0\<^sub>m 1 (m - 1) + B * D) + (0\<^sub>m 0 (dim_col A) * 1\<^sub>m 1 + 0\<^sub>m 0 (dim_col B) * 0\<^sub>m (m - 1) 1) + (0\<^sub>m 0 (dim_col A) * 0\<^sub>m 1 (m - 1) + 0\<^sub>m 0 (dim_col B) * D)" + by (rule mult_four_block_mat, insert assms, auto) + also have "... = four_block_mat A (B * D) (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col (B*D)))" + by (rule cong_four_block_mat, insert assms, auto) + also have "... = A @\<^sub>c (B * D)" unfolding append_cols_def by auto + finally show ?thesis . +qed + + +lemma append_cols_mult_right_id2: + assumes A: "(A::'a::semiring_1 mat) \ carrier_mat n a" + and B: "B \ carrier_mat n b" + and C: "C = four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)" + and D: "D \ carrier_mat a a" +shows "(A @\<^sub>c B) * C = (A * D) @\<^sub>c B" +proof - + let ?C = "four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)" + have "(A @\<^sub>c B) * C = (A @\<^sub>c B) * ?C" unfolding C by auto + also have "... = four_block_mat A B (0\<^sub>m 0 a) (0\<^sub>m 0 b) * ?C" + unfolding append_cols_def using A B by auto + also have "... = four_block_mat (A * D + B * 0\<^sub>m b a) (A * 0\<^sub>m a b + B * 1\<^sub>m b) + (0\<^sub>m 0 a * D + 0\<^sub>m 0 b * 0\<^sub>m b a) (0\<^sub>m 0 a * 0\<^sub>m a b + 0\<^sub>m 0 b * 1\<^sub>m b)" + by (rule mult_four_block_mat, insert A B C D, auto) + also have "... = four_block_mat (A * D) B (0\<^sub>m 0 (dim_col (A*D))) (0\<^sub>m 0 (dim_col B))" + by (rule cong_four_block_mat, insert assms, auto) + also have "... = (A * D) @\<^sub>c B" unfolding append_cols_def by auto + finally show ?thesis . +qed + + +lemma append_cols_nth: + assumes A: "A \ carrier_mat n a" + and B: "B \ carrier_mat n b" + and i: "ic B) $$ (i, j) = (if j < dim_col A then A $$(i,j) else B$$(i,j-a))" (is "?lhs = ?rhs") +proof - + let ?C = "(0\<^sub>m 0 (dim_col A))" + let ?D = "(0\<^sub>m 0 (dim_col B))" + have i2: "i < dim_row A + dim_row ?D" using i A by auto + have j2: "j < dim_col A + dim_col (0\<^sub>m 0 (dim_col B))" using j B A by auto + have "(A @\<^sub>c B) $$ (i, j) = four_block_mat A B ?C ?D $$ (i, j)" + unfolding append_cols_def by auto + also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j) + else B $$ (i, j - dim_col A) else if j < dim_col A then ?C $$ (i - dim_row A, j) + else 0\<^sub>m 0 (dim_col B) $$ (i - dim_row A, j - dim_col A))" + by (rule index_mat_four_block(1)[OF i2 j2]) + also have "... = ?rhs" using i A by auto + finally show ?thesis . +qed + +lemma append_cols_split: + assumes d: "dim_col A > 0" + shows "A = mat_of_cols (dim_row A) [col A 0] @\<^sub>c + mat_of_cols (dim_row A) (map (col A) [1..c ?A2") +proof (rule eq_matI) + fix i j assume i: "i < dim_row (?A1 @\<^sub>c ?A2)" and j: "j < dim_col (?A1 @\<^sub>c ?A2)" + have "(?A1 @\<^sub>c ?A2) $$ (i, j) = (if j < dim_col ?A1 then ?A1 $$(i,j) else ?A2$$(i,j-(dim_col ?A1)))" + by (rule append_cols_nth, insert i j, auto simp add: append_cols_def) + also have "... = A $$ (i,j)" + proof (cases "j< dim_col ?A1") + case True + then show ?thesis + by (metis One_nat_def Suc_eq_plus1 add.right_neutral append_cols_def col_def i + index_mat_four_block(2) index_vec index_zero_mat(2) less_one list.size(3) list.size(4) + mat_of_cols_Cons_index_0 mat_of_cols_carrier(2) mat_of_cols_carrier(3)) + next + case False + then show ?thesis + by (metis (no_types, lifting) Suc_eq_plus1 Suc_less_eq Suc_pred add_diff_cancel_right' append_cols_def + diff_zero i index_col index_mat_four_block(2) index_mat_four_block(3) index_zero_mat(2) + index_zero_mat(3) j length_map length_upt linordered_semidom_class.add_diff_inverse list.size(3) + list.size(4) mat_of_cols_carrier(2) mat_of_cols_carrier(3) mat_of_cols_index nth_map_upt + plus_1_eq_Suc upt_0) + qed + finally show "A $$ (i, j) = (?A1 @\<^sub>c ?A2) $$ (i, j)" .. +qed (auto simp add: append_cols_def d) + + +lemma append_rows_nth: + assumes A: "A \ carrier_mat a n" + and B: "B \ carrier_mat b n" + and i: "ir B) $$ (i, j) = (if i < dim_row A then A $$(i,j) else B$$(i-a,j))" (is "?lhs = ?rhs") +proof - + let ?C = "(0\<^sub>m (dim_row A) 0)" + let ?D = "(0\<^sub>m (dim_row B) 0)" + have i2: "i < dim_row A + dim_row ?D" using i j A B by auto + have j2: "j < dim_col A + dim_col ?D" using i j A B by auto + have "(A @\<^sub>r B) $$ (i, j) = four_block_mat A ?C B ?D $$ (i, j)" + unfolding append_rows_def by auto + also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?C $$ (i, j - dim_col A) + else if j < dim_col A then B $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))" + by (rule index_mat_four_block(1)[OF i2 j2]) + also have "... = ?rhs" using i A j B by auto + finally show ?thesis . +qed + +lemma append_rows_split: + assumes k: "k\dim_row A" + shows "A = (mat_of_rows (dim_col A) [Matrix.row A i. i \ [0..r + (mat_of_rows (dim_col A) [Matrix.row A i. i \ [k..r ?A2") +proof (rule eq_matI) + have "(?A1 @\<^sub>r ?A2) \ carrier_mat (k + (dim_row A-k)) (dim_col A)" + by (rule carrier_append_rows, insert k, auto) + hence A1_A2: "(?A1 @\<^sub>r ?A2) \ carrier_mat (dim_row A) (dim_col A)" using k by simp + thus "dim_row A = dim_row (?A1 @\<^sub>r ?A2)" and "dim_col A = dim_col (?A1 @\<^sub>r ?A2)" by auto + fix i j assume i: "i < dim_row (?A1 @\<^sub>r ?A2)" and j: "j < dim_col (?A1 @\<^sub>r ?A2)" + have "(?A1 @\<^sub>r ?A2) $$ (i, j) = (if i < dim_row ?A1 then ?A1 $$(i,j) else ?A2$$(i-(dim_row ?A1),j))" + by (rule append_rows_nth, insert k i j, auto simp add: append_rows_def) + also have "... = A $$ (i,j)" + proof (cases "ir ?A2) $$ (i,j)" by simp +qed + + + +lemma transpose_mat_append_rows: + assumes A: "A \ carrier_mat a n" and B: "B \ carrier_mat b n" + shows "(A @\<^sub>r B)\<^sup>T = A\<^sup>T @\<^sub>c B\<^sup>T" + by (smt append_cols_def append_rows_def A B carrier_matD(1) index_transpose_mat(3) + transpose_four_block_mat zero_carrier_mat zero_transpose_mat) + +lemma transpose_mat_append_cols: + assumes A: "A \ carrier_mat n a" and B: "B \ carrier_mat n b" + shows "(A @\<^sub>c B)\<^sup>T = A\<^sup>T @\<^sub>r B\<^sup>T" + by (metis Matrix.transpose_transpose A B carrier_matD(1) carrier_mat_triv + index_transpose_mat(3) transpose_mat_append_rows) + + +lemma append_rows_mult_right: + assumes A: "(A::'a::comm_semiring_1 mat) \ carrier_mat a n" and B: "B \ carrier_mat b n" + and Q: "Q\ carrier_mat n n" + shows "(A @\<^sub>r B) * Q = (A * Q) @\<^sub>r (B*Q)" +proof - + have "transpose_mat ((A @\<^sub>r B) * Q) = Q\<^sup>T * (A @\<^sub>r B)\<^sup>T" + by (rule transpose_mult, insert A B Q, auto) + also have "... = Q\<^sup>T * (A\<^sup>T @\<^sub>c B\<^sup>T)" using transpose_mat_append_rows assms by metis + also have "... = Q\<^sup>T * A\<^sup>T @\<^sub>c Q\<^sup>T * B\<^sup>T" + using append_cols_mult_left assms by (metis transpose_carrier_mat) + also have "transpose_mat ... = (A * Q) @\<^sub>r (B*Q)" + by (smt A B Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def Q + carrier_mat_triv index_mult_mat(2) index_transpose_mat(2) transpose_four_block_mat + zero_carrier_mat zero_transpose_mat) + finally show ?thesis by simp +qed + +lemma append_rows_mult_left_id: + assumes A: "(A::'a::comm_semiring_1 mat) \ carrier_mat 1 n" + and B: "B \ carrier_mat (m-1) n" + and C: "C = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D" + and D: "D \ carrier_mat (m-1) (m-1)" +shows "C * (A @\<^sub>r B) = A @\<^sub>r (D * B)" +proof - + have "transpose_mat (C * (A @\<^sub>r B)) = (A @\<^sub>r B)\<^sup>T * C\<^sup>T" + by (metis (no_types, lifting) B C D Matrix.transpose_mult append_rows_def A carrier_matD + carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2) one_carrier_mat) + also have "... = (A\<^sup>T @\<^sub>c B\<^sup>T) * C\<^sup>T" using transpose_mat_append_rows[OF A B] by auto + also have "... = A\<^sup>T @\<^sub>c (B\<^sup>T * D\<^sup>T)" by (rule append_cols_mult_right_id, insert A B C D, auto) + also have "transpose_mat ... = A @\<^sub>r (D * B)" + by (smt B D Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def A + carrier_matD(2) carrier_mat_triv index_mult_mat(3) index_transpose_mat(3) + transpose_four_block_mat zero_carrier_mat zero_transpose_mat) + finally show ?thesis by auto +qed + +lemma append_rows_mult_left_id2: + assumes A: "(A::'a::comm_semiring_1 mat) \ carrier_mat a n" + and B: "B \ carrier_mat b n" + and C: "C = four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)" + and D: "D \ carrier_mat a a" + shows "C * (A @\<^sub>r B) = (D * A) @\<^sub>r B" +proof - + have "(C * (A @\<^sub>r B))\<^sup>T = (A @\<^sub>r B)\<^sup>T * C\<^sup>T" by (rule transpose_mult, insert assms, auto) + also have "... = (A\<^sup>T @\<^sub>c B\<^sup>T) * C\<^sup>T" by (metis A B transpose_mat_append_rows) + also have "... = (A\<^sup>T * D\<^sup>T @\<^sub>c B\<^sup>T)" by (rule append_cols_mult_right_id2, insert assms, auto) + also have "...\<^sup>T = (D * A) @\<^sub>r B" + by (metis A B D transpose_mult transpose_transpose mult_carrier_mat transpose_mat_append_rows) + finally show ?thesis by simp +qed + +lemma four_block_mat_preserves_column: + assumes A: "(A::'a::semiring_1 mat) \ carrier_mat n m" + and B: "B = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) C" + and C: "C \ carrier_mat (m-1) (m-1)" + and i: "ic ?A2" by (rule append_cols_split[of A, unfolded n2], insert m A, auto) + hence "A * B = (?A1 @\<^sub>c ?A2) * B" by simp + also have "... = ?A1 @\<^sub>c (?A2 * C)" by (rule append_cols_mult_right_id[OF _ _ B C], insert A, auto) + also have "... $$ (i,0) = ?A1 $$ (i,0)" using append_cols_nth by (simp add: append_cols_def i) + also have "... = A $$ (i,0)" + by (metis A i carrier_matD(1) col_def index_vec mat_of_cols_Cons_index_0) + finally show ?thesis . +qed + + +definition "lower_triangular A = (\i j. i < j \ i < dim_row A \ j < dim_col A \ A $$ (i,j) = 0)" + +lemma lower_triangular_index: + assumes "lower_triangular A" "i carrier_mat n n" + shows "A * (k \\<^sub>m (1\<^sub>m n)) = (k \\<^sub>m (1\<^sub>m n)) * A" +proof - + have "(\ia = 0..ia = 0..ia \ ({0..ia \ ({0..ia \ ({0..ia \ ({0.. carrier_mat 2 2" + shows "Determinant.det A = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)" +proof - + let ?A = "(Mod_Type_Connect.to_hma\<^sub>m A)::'a^2^2" + have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A" + unfolding Mod_Type_Connect.HMA_M_def using from_hma_to_hma\<^sub>m A by auto + have [transfer_rule]: "Mod_Type_Connect.HMA_I 0 0" + unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_0) + have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 1" + unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1) + have "Determinant.det A = Determinants.det ?A" by (transfer, simp) + also have "... = ?A $h 1 $h 1 * ?A $h 2 $h 2 - ?A $h 1 $h 2 * ?A $h 2 $h 1" unfolding det_2 by simp + also have "... = ?A $h 0 $h 0 * ?A $h 1 $h 1 - ?A $h 0 $h 1 * ?A $h 1 $h 0" + by (smt Groups.mult_ac(2) exhaust_2 semiring_norm(160)) + also have "... = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)" + unfolding index_hma_def[symmetric] by (transfer, auto) + finally show ?thesis . +qed + +lemma mat_diag_smult: "mat_diag n (\ x. (k::'a::comm_ring_1)) = (k \\<^sub>m 1\<^sub>m n)" +proof - + have "mat_diag n (\ x. k) = mat_diag n (\ x. k * 1)" by auto + also have "... = mat_diag n (\ x. k) * mat_diag n (\ x. 1)" using mat_diag_diag + by (simp add: mat_diag_def) + also have "... = mat_diag n (\ x. k) * (1\<^sub>m n)" by auto thm mat_diag_mult_left + also have "... = Matrix.mat n n (\(i, j). k * (1\<^sub>m n) $$ (i, j))" by (rule mat_diag_mult_left, auto) + also have "... = (k \\<^sub>m 1\<^sub>m n)" unfolding smult_mat_def by auto + finally show ?thesis . +qed + +lemma invertible_mat_four_block_mat_lower_right: + assumes A: "(A::'a::comm_ring_1 mat) \ carrier_mat n n" and inv_A: "invertible_mat A" + shows "invertible_mat (four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 n) (0\<^sub>m n 1) A)" +proof - + let ?I = "(four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 n) (0\<^sub>m n 1) A)" + have "Determinant.det ?I = Determinant.det (1\<^sub>m 1) * Determinant.det A" + by (rule det_four_block_mat_lower_left_zero_col, insert assms, auto) + also have "... = Determinant.det A" by auto + finally have "Determinant.det ?I = Determinant.det A" . + thus ?thesis + by (metis (no_types, lifting) assms carrier_matD(1) carrier_matD(2) carrier_mat_triv + index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3) + invertible_iff_is_unit_JNF) +qed + + +lemma invertible_mat_four_block_mat_lower_right_id: + assumes A: "(A::'a::comm_ring_1 mat) \ carrier_mat m m" and B: "B = 0\<^sub>m m (n-m)" and C: "C = 0\<^sub>m (n-m) m" + and D: "D = 1\<^sub>m (n-m)" and "n>m" and inv_A: "invertible_mat A" + shows "invertible_mat (four_block_mat A B C D)" +proof - + have "Determinant.det (four_block_mat A B C D) = Determinant.det A" + by (rule det_four_block_mat_lower_right_id, insert assms, auto) + thus ?thesis using inv_A + by (metis (no_types, lifting) assms(1) assms(4) carrier_matD(1) carrier_matD(2) carrier_mat_triv + index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3) + invertible_iff_is_unit_JNF) +qed + +lemma split_block4_decreases_dim_row: + assumes E: "(A,B,C,D) = split_block E 1 1" + and E1: "dim_row E > 1" and E2: "dim_col E > 1" + shows "dim_row D < dim_row E" +proof - + have "D \ carrier_mat (1 + (dim_row E - 2)) (1 + (dim_col E - 2))" + by (rule split_block(4)[OF E[symmetric]], insert E1 E2, auto) + hence "D \ carrier_mat (dim_row E - 1) (dim_col E - 1)" using E1 E2 by auto + thus ?thesis using E1 by auto +qed + + +lemma inv_P'PAQQ': + assumes A: "A \ carrier_mat n n" + and P: "P \ carrier_mat n n" + and inv_P: "inverts_mat P' P" + and inv_Q: "inverts_mat Q Q'" + and Q: "Q \ carrier_mat n n" + and P': "P' \ carrier_mat n n" + and Q': "Q' \ carrier_mat n n" +shows "(P'*(P*A*Q)*Q') = A" +proof - + have "(P'*(P*A*Q)*Q') = (P'*(P*A*Q*Q'))" + by (smt P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv + index_mult_mat(2) index_mult_mat(3)) + also have "... = ((P'*P)*A*(Q*Q'))" + by (smt A P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv + index_mult_mat(3) inv_Q inverts_mat_def right_mult_one_mat') + finally show ?thesis + by (metis P' Q A inv_P inv_Q carrier_matD(1) inverts_mat_def + left_mult_one_mat right_mult_one_mat) +qed + +lemma + assumes "U \ carrier_mat 2 2" and "V \ carrier_mat 2 2" and "A = U * V" +shows mat_mult2_00: "A $$ (0,0) = U $$ (0,0)*V $$ (0,0) + U $$ (0,1)*V $$ (1,0)" + and mat_mult2_01: "A $$ (0,1) = U $$ (0,0)*V $$ (0,1) + U $$ (0,1)*V $$ (1,1)" + and mat_mult2_10: "A $$ (1,0) = U $$ (1,0)*V $$ (0,0) + U $$ (1,1)*V $$ (1,0)" + and mat_mult2_11: "A $$ (1,1) = U $$ (1,0)*V $$ (0,1) + U $$ (1,1)*V $$ (1,1)" + using assms unfolding times_mat_def Matrix.row_def col_def scalar_prod_def + using sum_two_rw by auto + + +subsection\Lemmas about @{text "sorted lists"}, @{text "insort"} and @{text "pick"}\ + + +lemma sorted_distinct_imp_sorted_wrt: + assumes "sorted xs" and "distinct xs" + shows "sorted_wrt (<) xs" + using assms + by (induct xs, insert le_neq_trans, auto) + + +lemma sorted_map_strict: + assumes "strict_mono_on g {0.. g ` {0..x\set (map g [0.. g n" using sg unfolding strict_mono_on_def + by (simp add: less_imp_le) + qed + finally show ?case . +qed + + +lemma sorted_nth_strict_mono: + "sorted xs \ distinct xs \i < j \ j < length xs \ xs!i < xs!j" + by (simp add: less_le nth_eq_iff_index_eq sorted_iff_nth_mono_less) + + +lemma sorted_list_of_set_0_LEAST: + assumes finI: "finite I" and I: "I \ {}" + shows "sorted_list_of_set I ! 0 = (LEAST n. n\I)" +proof (rule Least_equality[symmetric]) + show "sorted_list_of_set I ! 0 \ I" + by (metis I Max_in finI gr_zeroI in_set_conv_nth not_less_zero set_sorted_list_of_set) + fix y assume "y \ I" + thus "sorted_list_of_set I ! 0 \ y" + by (metis eq_iff finI in_set_conv_nth neq0_conv sorted_iff_nth_mono_less + sorted_list_of_set(1) sorted_sorted_list_of_set) +qed + +lemma sorted_list_of_set_eq_pick: + assumes i: "i < length (sorted_list_of_set I)" + shows "sorted_list_of_set I ! i = pick I i" +proof - + have finI: "finite I" + proof (rule ccontr) + assume "infinite I" + hence "length (sorted_list_of_set I) = 0" using sorted_list_of_set.infinite by auto + thus False using i by simp + qed + show ?thesis + using i +proof (induct i) + case 0 + have I: "I \ {}" using "0.prems" sorted_list_of_set_empty by blast + show ?case unfolding pick.simps by (rule sorted_list_of_set_0_LEAST[OF finI I]) +next + case (Suc i) + note x_less = Suc.prems + show ?case + proof (unfold pick.simps, rule Least_equality[symmetric], rule conjI) + show 1: "pick I i < sorted_list_of_set I ! Suc i" + by (metis Suc.hyps Suc.prems Suc_lessD distinct_sorted_list_of_set find_first_unique lessI + nat_less_le sorted_sorted_list_of_set sorted_sorted_wrt sorted_wrt_nth_less) + show "sorted_list_of_set I ! Suc i \ I" + using Suc.prems finI nth_mem set_sorted_list_of_set by blast + have rw: "sorted_list_of_set I ! i = pick I i" + by (rule Suc.hyps, simp add: Suc.prems Suc_lessD) + have sorted_less: "sorted_list_of_set I ! i < sorted_list_of_set I ! Suc i" + by (simp add: 1 rw) + fix y assume y: "y \ I \ pick I i < y" + show "sorted_list_of_set I ! Suc i \ y" + by (smt antisym_conv finI in_set_conv_nth less_Suc_eq less_Suc_eq_le nat_neq_iff rw + sorted_iff_nth_mono_less sorted_list_of_set(1) sorted_sorted_list_of_set x_less y) + qed +qed +qed + +text\$b$ is the position where we add, $a$ the element to be added and $i$ the position + that is checked\ + +lemma insort_nth': + assumes "\j set xs" + and "i < length xs + 1" and "i < b" + and "xs \ []" and "b < length xs" + shows "insort a xs ! i = xs ! i" + using assms +proof (induct xs arbitrary: a b i) + case Nil + then show ?case by auto +next + case (Cons x xs) + note less = Cons.prems(1) + note sorted = Cons.prems(2) + note a_notin = Cons.prems(3) + note i_length = Cons.prems(4) + note i_b = Cons.prems(5) + note b_length = Cons.prems(7) + show ?case + proof (cases "a \ x") + case True + have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp + also have "... = (x # xs) ! i" + using Cons.prems(1) Cons.prems(5) True by force + finally show ?thesis . + next + case False note x_less_a = False + have "insort a (x # xs) ! i = (x # insort a xs) ! i" using False by simp + also have "... = (x # xs) ! i" + proof (cases "i = 0") + case True + then show ?thesis by auto + next + case False + have "(x # insort a xs) ! i = (insort a xs) ! (i-1)" + by (simp add: False nth_Cons') + also have "... = xs ! (i-1)" + proof (rule Cons.hyps) + show "sorted xs" using sorted by simp + show "a \ set xs" using a_notin by simp + show "i - 1 < length xs + 1" using i_length False by auto + show "xs \ []" using i_b b_length by force + show "i - 1 < b - 1" by (simp add: False diff_less_mono i_b leI) + show "b - 1 < length xs" using b_length i_b by auto + show "\j set xs" + and "i < index (insort a xs) a" + and "xs \ []" + shows "insort a xs ! i = xs ! i" + using assms +proof (induct xs arbitrary: a i) +case Nil + then show ?case by auto +next + case (Cons x xs) + note sorted = Cons.prems(1) + note a_notin = Cons.prems(2) + note i_index = Cons.prems(3) + show ?case + proof (cases "a \ x") + case True + have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp + also have "... = (x # xs) ! i" + using Cons.prems(1) Cons.prems(3) True by force + finally show ?thesis . + next + case False note x_less_a = False + show ?thesis + proof (cases "xs = []") + case True + have "x \ a" using False by auto + then show ?thesis using True i_index False by auto + next + case False note xs_not_empty = False + have "insort a (x # xs) ! i = (x # insort a xs) ! i" using x_less_a by simp + also have "... = (x # xs) ! i" + proof (cases "i = 0") + case True + then show ?thesis by auto + next + case False note i0 = False + have "(x # insort a xs) ! i = (insort a xs) ! (i-1)" + by (simp add: False nth_Cons') + also have "... = xs ! (i-1)" + proof (rule Cons.hyps[OF _ _ _ xs_not_empty]) + show "sorted xs" using sorted by simp + show "a \ set xs" using a_notin by simp + have "index (insort a (x # xs)) a = index ((x # insort a xs)) a" + using x_less_a by auto + also have "... = index (insort a xs) a + 1" + unfolding index_Cons using x_less_a by simp + finally show "i - 1 < index (insort a xs) a" using False i_index by linarith + qed + also have "... = (x # xs) ! i" by (simp add: False nth_Cons') + finally show ?thesis . + qed + finally show ?thesis . + qed + qed +qed + +lemma insort_nth2: + assumes "sorted xs" and "a \ set xs" + and "i < length xs" and "i \ index (insort a xs) a" + and "xs \ []" + shows "insort a xs ! (Suc i) = xs ! i" + using assms +proof (induct xs arbitrary: a i) + case Nil + then show ?case by auto +next + case (Cons x xs) + note sorted = Cons.prems(1) + note a_notin = Cons.prems(2) + note i_length = Cons.prems(3) + note index_i = Cons.prems(4) + show ?case + proof (cases "a \ x") + case True + have "insort a (x # xs) ! (Suc i) = (a # x # xs) ! (Suc i)" using True by simp + also have "... = (x # xs) ! i" + using Cons.prems(1) Cons.prems(5) True by force + finally show ?thesis . + next + case False note x_less_a = False + have "insort a (x # xs) ! (Suc i) = (x # insort a xs) ! (Suc i)" using False by simp + also have "... = (x # xs) ! i" + proof (cases "i = 0") + case True + then show ?thesis using index_i linear x_less_a by fastforce + next + case False note i0 = False + show ?thesis + proof - + have Suc_i: "Suc (i - 1) = i" + using i0 by auto + have "(x # insort a xs) ! (Suc i) = (insort a xs) ! i" + by (simp add: nth_Cons') + also have "... = (insort a xs) ! Suc (i - 1)" using Suc_i by simp + also have "... = xs ! (i - 1)" + proof (rule Cons.hyps) + show "sorted xs" using sorted by simp + show "a \ set xs" using a_notin by simp + show "i - 1 < length xs" using i_length using Suc_i by auto + thus "xs \ []" by auto + have "index (insort a (x # xs)) a = index ((x # insort a xs)) a" using x_less_a by simp + also have "... = index (insort a xs) a + 1" unfolding index_Cons using x_less_a by simp + finally show "index (insort a xs) a \ i - 1" using index_i i0 by auto + qed + also have "... = (x # xs) ! i" using Suc_i by auto + finally show ?thesis . + qed + qed + finally show ?thesis . + qed +qed + +lemma pick_index: + assumes a: "a \ I" and a'_card: "a' < card I" + shows "(pick I a' = a) = (index (sorted_list_of_set I) a = a')" +proof - + have finI: "finite I" using a'_card card_infinite by force + have length_I: "length (sorted_list_of_set I) = card I" + by (metis a'_card card_infinite distinct_card distinct_sorted_list_of_set + not_less_zero set_sorted_list_of_set) + let ?i = "index (sorted_list_of_set I) a" + have "(sorted_list_of_set I) ! a' = pick I a'" + by (rule sorted_list_of_set_eq_pick, auto simp add: finI a'_card length_I) + moreover have "(sorted_list_of_set I) ! ?i = a" + by (rule nth_index, simp add: a finI) + ultimately show ?thesis + by (metis a'_card distinct_sorted_list_of_set index_nth_id length_I) +qed + +end + diff --git a/thys/Smith_Normal_Form/SNF_Uniqueness.thy b/thys/Smith_Normal_Form/SNF_Uniqueness.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/SNF_Uniqueness.thy @@ -0,0 +1,1180 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Uniqueness of the Smith normal form\ + +theory SNF_Uniqueness +imports + Cauchy_Binet + Smith_Normal_Form_JNF + Admits_SNF_From_Diagonal_Iff_Bezout_Ring +begin + +lemma dvd_associated1: + fixes a::"'a::comm_ring_1" + assumes "\u. u dvd 1 \ a = u*b" + shows "a dvd b \ b dvd a" + using assms by auto + + +text \This is a key lemma. It demands the type class to be an integral domain. This means that +the uniqueness result will be obtained for GCD domains, instead of rings.\ +lemma dvd_associated2: + fixes a::"'a::idom" + assumes ab: "a dvd b" and ba: "b dvd a" and a: "a\0" + shows "\u. u dvd 1 \ a = u*b" +proof - + obtain k where a_kb: "a = k*b" using ab unfolding dvd_def + by (metis Groups.mult_ac(2) ba dvdE) + obtain q where b_qa: "b = q*a" using ba unfolding dvd_def + by (metis Groups.mult_ac(2) ab dvdE) + have 1: "a = k*q*a" using a_kb b_qa by auto + hence "k*q = 1" using a by simp + thus ?thesis using 1 by (metis a_kb dvd_triv_left) +qed + +corollary dvd_associated: + fixes a::"'a::idom" + assumes "a\0" + shows "(a dvd b \ b dvd a) = (\u. u dvd 1 \ a = u*b)" + using assms dvd_associated1 dvd_associated2 by metis + + +lemma exists_inj_ge_index: + assumes S: "S \ {0..f. inj_on f {0.. f`{0.. (\i\{0.. f i)" +proof - + have "\h. bij_betw h {0..i\{0.. ?f i" + proof + fix i assume i: "i \ {0.. ?xs ! i" + proof (rule sorted_wrt_less_idx, rule sorted_distinct_imp_sorted_wrt) + show "sorted ?xs" + using sorted_sorted_list_of_set by blast + show "distinct ?xs" using distinct_sorted_list_of_set by blast + show "i < length ?xs" + by (metis S Sk atLeast0LessThan distinct_card distinct_sorted_list_of_set gk_S i + lessThan_iff set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite) + qed + ultimately show "i \ ?f i" by auto + qed + show ?thesis using 1 2 3 by auto +qed + + +subsection \More specific results about submatrices\ + + +lemma diagonal_imp_submatrix0: + assumes dA: "diagonal_mat A" and A_carrier: "A\ carrier_mat n m" + and Ik: "card I = k" and Jk: "card J = k" + and r: "\row_index \ I. row_index < n" (*I \ {0..col_index \ J. col_index < m" + and a: "a submatrix A I J $$ (a,b) = A $$(pick I a, pick I a)" +proof (cases "submatrix A I J $$ (a, b) = 0") + case True + then show ?thesis by auto +next + case False note not0 = False + have aux: "submatrix A I J $$ (a, b) = A $$(pick I a, pick J b)" + proof (rule submatrix_index) + have "card {i. i < dim_row A \ i \ I} = k" + by (smt A_carrier Ik carrier_matD(1) equalityI mem_Collect_eq r subsetI) + moreover have "card {i. i < dim_col A \ i \ J} = k" + by (metis (no_types, lifting) A_carrier Jk c carrier_matD(2) carrier_mat_def + equalityI mem_Collect_eq subsetI) + ultimately show " a < card {i. i < dim_row A \ i \ I}" + and "b < card {i. i < dim_col A \ i \ J}" using a b by auto + qed + thus ?thesis + proof (cases "pick I a = pick J b") + case True + then show ?thesis using aux by auto + next + case False + then show ?thesis + by (metis aux A_carrier Ik Jk a b c carrier_matD dA diagonal_mat_def pick_in_set_le r) + qed +qed + + + +lemma diagonal_imp_submatrix_element_not0: + assumes dA: "diagonal_mat A" + and A_carrier: "A \ carrier_mat n m" + and Ik: "card I = k" and Jk: "card J = k" + and I: "I \ {0.. {0..i. i submatrix A I J $$ (i, b) \ 0" +shows "\!i. i submatrix A I J $$ (i, b) \ 0" +proof - + have I_eq: "I = {i. i < dim_row A \ i \ I}" using I A_carrier unfolding carrier_mat_def by auto + have J_eq: "J = {i. i < dim_col A \ i \ J}" using J A_carrier unfolding carrier_mat_def by auto + obtain a where sub_ab: "submatrix A I J $$ (a, b) \ 0" and ak: "a < k" using ex_not0 by auto + moreover have "i = a" if sub_ib: "submatrix A I J $$ (i, b) \ 0" and ik: "i < k" for i + proof - + have 1: "pick I i < dim_row A" + using I_eq Ik ik pick_in_set_le by auto + have 2: "pick J b < dim_col A" + using J_eq Jk b pick_le by auto + have 3: "pick I a < dim_row A" + using I_eq Ik calculation(2) pick_le by auto + have "submatrix A I J $$ (i, b) = A $$ (pick I i, pick J b)" + by (rule submatrix_index, insert I_eq Ik ik J_eq Jk b, auto) + hence pick_Ii_Jb: "pick I i = pick J b" using dA sub_ib 1 2 unfolding diagonal_mat_def by auto + have "submatrix A I J $$ (a, b) = A $$ (pick I a, pick J b)" + by (rule submatrix_index, insert I_eq Ik ak J_eq Jk b, auto) + hence pick_Ia_Jb: "pick I a = pick J b" using dA sub_ab 3 2 unfolding diagonal_mat_def by auto + have pick_Ia_Ii: "pick I a = pick I i" using pick_Ii_Jb pick_Ia_Jb by simp + thus ?thesis by (metis Ik ak ik nat_neq_iff pick_mono_le) + qed + ultimately show ?thesis by auto +qed + + +lemma submatrix_index_exists: + assumes A_carrier: "A\ carrier_mat n m" + and Ik: "card I = k" and Jk: "card J = k" + and a: "a \ I" and b: "b \ J" and k: "k > 0" + and I: "I \ {0.. {0..a' b'. a' < k \ b' < k \ submatrix A I J $$ (a',b') = A $$ (a,b) + \ a = pick I a' \ b = pick J b'" +proof - + let ?xs = "sorted_list_of_set I" + let ?ys = "sorted_list_of_set J" + have finI: "finite I" and finJ: "finite J" using k Ik Jk card_ge_0_finite by metis+ + have set_xs: "set ?xs = I" by (rule set_sorted_list_of_set[OF finI]) + have set_ys: "set ?ys = J" by (rule set_sorted_list_of_set[OF finJ]) + have a_in_xs: "a \ set ?xs" and b_in_ys: "b \ set ?ys" using set_xs a set_ys b by auto + have length_xs: "length ?xs = k" by (metis Ik distinct_card set_xs sorted_list_of_set(3)) + have length_ys: "length ?ys = k" by (metis Jk distinct_card set_ys sorted_list_of_set(3)) + obtain a' where a': "?xs ! a' = a" and a'_length: "a' < length ?xs" + by (meson a_in_xs in_set_conv_nth) + obtain b' where b': "?ys ! b' = b" and b'_length: "b' < length ?ys" + by (meson b_in_ys in_set_conv_nth) + have pick_a: "a = pick I a'" using a' a'_length finI sorted_list_of_set_eq_pick by auto + have pick_b: "b = pick J b'" using b' b'_length finJ sorted_list_of_set_eq_pick by auto + have I_rw: "I = {i. i < dim_row A \ i \ I}" and J_rw: "J = {i. i < dim_col A \ i \ J}" + using I A_carrier J by auto + have a'k: "a' < k" using a'_length length_xs by auto + moreover have b'k: "b' carrier_mat n m" + and Ik: "card I = k" and Jk: "card J = k" + and I: "I \ {0.. {0.. I" and b_notin_J: "b \ J" + and a'k: "a' < Suc k" and b'k: "b' < Suc k" + and a_def: "pick (insert a I) a' = a" + and b_def: "pick (insert b J) b' = b" +shows "mat_delete (submatrix A (insert a I) (insert b J)) a' b' = submatrix A I J" (is "?lhs = ?rhs") +proof (rule eq_matI) + have I_eq: "I = {i. i < dim_row A \ i \ I}" + using I A_carrier unfolding carrier_mat_def by auto + have J_eq: "J = {i. i < dim_col A \ i \ J}" + using J A_carrier unfolding carrier_mat_def by auto + have insert_I_eq: "insert a I = {i. i < dim_row A \ i \ insert a I}" + using I A_carrier a k unfolding carrier_mat_def by auto + have card_Suc_k: "card {i. i < dim_row A \ i \ insert a I} = Suc k" + using insert_I_eq Ik a_notin_I + by (metis I card_insert_disjoint finite_atLeastLessThan finite_subset) + have insert_J_eq: "insert b J = {i. i < dim_col A \ i \ insert b J}" + using J A_carrier b k unfolding carrier_mat_def by auto + have card_Suc_k': "card {i. i < dim_col A \ i \ insert b J} = Suc k" + using insert_J_eq Jk b_notin_J + by (metis J card_insert_disjoint finite_atLeastLessThan finite_subset) + show "dim_row ?lhs = dim_row ?rhs" + unfolding mat_delete_dim unfolding dim_submatrix using card_Suc_k I_eq Ik by auto + show "dim_col ?lhs = dim_col ?rhs" + unfolding mat_delete_dim unfolding dim_submatrix using card_Suc_k' J_eq Jk by auto + fix i j assume i: "i < dim_row (submatrix A I J)" + and j: "j < dim_col (submatrix A I J)" + have ik: "i < k" by (metis I_eq Ik dim_submatrix(1) i) + have jk: "j < k" by (metis J_eq Jk dim_submatrix(2) j) + show "?lhs $$ (i, j) = ?rhs $$ (i, j)" + proof - + have index_eq1: "pick (insert a I) (insert_index a' i) = pick I i" + by (rule pick_insert_index[OF Ik a_notin_I ik a_def], simp add: Ik a'k) + have index_eq2: "pick (insert b J) (insert_index b' j) = pick J j" + by (rule pick_insert_index[OF Jk b_notin_J jk b_def], simp add: Jk b'k) + have "?lhs $$ (i,j) + = (submatrix A (insert a I) (insert b J)) $$ (insert_index a' i, insert_index b' j)" + proof (rule mat_delete_index[symmetric, OF _ a'k b'k ik jk]) + show "submatrix A (insert a I) (insert b J) \ carrier_mat (Suc k) (Suc k)" + by (metis card_Suc_k card_Suc_k' carrier_matI dim_submatrix(1) dim_submatrix(2)) + qed + also have "... = A $$ (pick (insert a I) (insert_index a' i), pick (insert b J) (insert_index b' j))" + proof (rule submatrix_index) + show "insert_index a' i < card {i. i < dim_row A \ i \ insert a I}" + using card_Suc_k ik insert_index_def by auto + show "insert_index b' j < card {j. j < dim_col A \ j \ insert b J}" + using card_Suc_k' insert_index_def jk by auto + qed + also have "... = A $$ (pick I i, pick J j)" unfolding index_eq1 index_eq2 by auto + also have "... = submatrix A I J $$ (i,j)" + by (rule submatrix_index[symmetric], insert ik I_eq Ik Jk J_eq jk, auto) + finally show ?thesis . + qed +qed + + + +subsection \On the minors of a diagonal matrix\ + +lemma det_minors_diagonal: + assumes dA: "diagonal_mat A" and A_carrier: "A \ carrier_mat n m" + and Ik: "card I = k" and Jk: "card J = k" + and r: "I \ {0.. {0..0" + shows "det (submatrix A I J) = 0 + \ (\xs. (det (submatrix A I J) = prod_list xs \ det (submatrix A I J) = - prod_list xs) + \ set xs \ {A$$(i,i)|i. i A$$(i,i)\ 0} \ length xs = k)" + using Ik Jk r c k +proof (induct k arbitrary: I J) + case 0 + then show ?case by auto +next + case (Suc k) + note cardI = Suc.prems(1) + note cardJ = Suc.prems(2) + note I = Suc.prems(3) + note J = Suc.prems(4) + have *: "{i. i < dim_row A \ i \ I} = I" using I Ik A_carrier carrier_mat_def by auto + have **: "{j. j < dim_col A \ j \ J} = J" using J Jk A_carrier carrier_mat_def by auto + show ?case + proof (cases "k = 0") + case True note k0 = True + from this obtain a where aI: "I = {a}" using True cardI card_1_singletonE by auto + from this obtain b where bJ: "J = {b}" using True cardJ card_1_singletonE by auto + have an: "a carrier_mat 1 1" + unfolding carrier_mat_def submatrix_def + using * ** aI bJ by auto + have 1: "det (submatrix A {a} {b}) = (submatrix A {a} {b}) $$ (0,0)" + by (rule det_singleton[OF sub_carrier]) + have 2: "... = A $$ (a,b)" + by (rule submatrix_singleton_index[OF A_carrier an bm]) + show ?thesis + proof (cases "A $$ (a,b) \ 0") + let ?xs = "[submatrix A {a} {b} $$ (0,0)]" + case True + hence "a = b" using dA A_carrier an bm unfolding diagonal_mat_def carrier_mat_def by auto + hence "set ?xs \ {A $$ (i, i) |i. i < min n m \ A $$ (i, i) \ 0}" + using 2 True an bm by auto + moreover have "det (submatrix A {a} {b}) = prod_list ?xs" using 1 by auto + moreover have "length ?xs = Suc k" using k0 by auto + ultimately show ?thesis using an bm unfolding aI bJ by blast + next + case False + then show ?thesis using 1 2 aI bJ by auto + qed + next + case False + hence k0: "0 < k" by simp + have k: "k < min n m" + by (metis I J cardI cardJ le_imp_less_Suc less_Suc_eq_le min.commute + min_def not_less subset_eq_atLeast0_lessThan_card) + have subIJ_carrier: "(submatrix A I J) \ carrier_mat (Suc k) (Suc k)" + unfolding carrier_mat_def using * ** cardI cardJ + unfolding submatrix_def by auto + obtain b' where b'k: "b' < Suc k" by auto + let ?f="\i. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b'" + have det_rw: "det (submatrix A I J) + = (\ia' 0") + case True + obtain a' where sub_IJ_0: "submatrix A I J $$ (a',b') \ 0" + and a'k: "a' < Suc k" + and unique: "\j. j submatrix A I J $$ (j,b') \ 0 \ j = a'" + using diagonal_imp_submatrix_element_not0[OF dA A_carrier cardI cardJ I J b'k True] by auto + have "submatrix A I J $$ (a', b') = A $$ (pick I a', pick J b')" + by (rule submatrix_index, auto simp add: "*" a'k cardI "**" b'k cardJ) + from this obtain a b where an: "a < n" and bm: "b < m" + and sub_index: "submatrix A I J $$ (a', b') = A $$ (a, b)" + and pick_a: "pick I a' = a" and pick_b: "pick J b' = b" + using * ** A_carrier a'k b'k cardI cardJ pick_le by fastforce + obtain I' where aI': "I = insert a I'" and a_notin: "a \ I'" + by (metis Set.set_insert a'k cardI pick_a pick_in_set_le) + obtain J' where bJ': "J = insert b J'" and b_notin: "b \ J'" + by (metis Set.set_insert b'k cardJ pick_b pick_in_set_le) + have Suc_k0: "0 < Suc k" by simp + have aI: "a \ I" using aI' by auto + have bJ: "b \ J" using bJ' by auto + have cardI': "card I' = k" + by (metis aI' a_notin cardI card_infinite card_insert_disjoint + finite_insert nat.inject nat.simps(3)) + have cardJ': "card J' = k" + by (metis bJ' b_notin cardJ card_infinite card_insert_disjoint + finite_insert nat.inject nat.simps(3)) + have I': "I' \ {0.. {0.. + (\xs. (det (submatrix A I' J') = prod_list xs \ det (submatrix A I' J') = - prod_list xs) + \ set xs \ {A $$ (i, i) |i. i < min n m \ A $$ (i, i) \ 0} \ length xs = k)" + proof (rule Suc.hyps[OF cardI' cardJ' _ _ k0]) + show "I' \ {0.. {0..i det (submatrix A I' J') = - prod_list xs" + and xs: "set xs \ {A $$ (i, i) |i. i < min n m \ A $$ (i, i) \ 0}" + and length_xs: "length xs = k" + using det_sub_I'J' by blast + let ?ys = "A$$(a,b) # xs" + have length_ys: "length ?ys = Suc k" using length_xs by auto + have a_eq_b: "a=b" + using A_carrier an bm sub_IJ_0 sub_index dA unfolding diagonal_mat_def by auto + have A_aa_in: "A$$(a,a) \ {A $$ (i, i) |i. i < min n m \ A $$ (i, i) \ 0}" + using a_eq_b an bm sub_IJ_0 sub_index by auto + have ys: "set ?ys \ {A $$ (i, i) |i. i < min n m \ A $$ (i, i) \ 0}" + using xs A_aa_in a_eq_b by auto + show ?thesis + proof (cases "even (a'+b')") + case True + have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * det (submatrix A I' J')" + using det_submatrix_IJ True by auto + show ?thesis + proof (cases "det (submatrix A I' J') = prod_list xs") + case True + have "det (submatrix A I J) = prod_list ?ys" + using det_submatrix_IJ unfolding True by auto + then show ?thesis using ys length_ys by blast + next + case False + hence "det (submatrix A I' J') = - prod_list xs" using prod_list_xs by simp + hence "det (submatrix A I J) = - prod_list ?ys" using det_submatrix_IJ by auto + then show ?thesis using ys length_ys by blast + qed + next + case False + have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * - det (submatrix A I' J')" + using det_submatrix_IJ False by auto + show ?thesis + proof (cases "det (submatrix A I' J') = prod_list xs") + case True + have "det (submatrix A I J) = - prod_list ?ys" + using det_submatrix_IJ unfolding True by auto + then show ?thesis using ys length_ys by blast + next + case False + hence "det (submatrix A I' J') = - prod_list xs" using prod_list_xs by simp + hence "det (submatrix A I J) = prod_list ?ys" using det_submatrix_IJ by auto + then show ?thesis using ys length_ys by blast + qed + qed + qed + next + case False + have "sum ?f {0.. {0.. J \ {0.. card I = k \ card J = k}" + + +lemma Gcd_minors_dvd: + fixes A::"'a::{semiring_Gcd,comm_ring_1} mat" + assumes PAQ_B: "P * A * Q = B" + and P: "P \ carrier_mat m m" + and A: "A \ carrier_mat m n" + and Q: "Q \ carrier_mat n n" + and I: "I \ {0.. {0.. carrier_mat k n" + proof - + have "I = {i. i < dim_row P \ i \ I}" using P I A by auto + hence "card {i. i < dim_row P \ i \ I} = k" using Ik by auto + thus ?thesis using A unfolding submatrix_def by auto + qed + have subQ: "submatrix Q UNIV J \ carrier_mat n k" + proof - + have J_eq: "J = {j. j < dim_col Q \ j \ J}" using Q J A by auto + hence "card {j. j < dim_col Q \ j \ J} = k" using Jk by auto + moreover have "card {i. i < dim_row Q \ i \ UNIV} = n" using Q by auto + ultimately show ?thesis unfolding submatrix_def by auto + qed + have sub_sub_PA: "(submatrix ?subPA UNIV I') = submatrix (P * A) I I'" for I' + using submatrix_split2[symmetric] by auto + have det_subPA_rw: "det (submatrix (P * A) I I') = + (\J' | J' \ {0.. card J' = k. det ((submatrix P I J')) * det (submatrix A J' I'))" + if I'1: "I' \ {0..C | C \ {0.. card C = k. + det (submatrix (submatrix P I UNIV) UNIV C) * det (submatrix (submatrix A UNIV I') C UNIV))" + proof (rule Cauchy_Binet) + have "I = {i. i < dim_row P \ i \ I}" using P I A by auto + thus "submatrix P I UNIV \ carrier_mat k m" using Ik P unfolding submatrix_def by auto + have "I' = {j. j < dim_col A \ j \ I'}" using I'1 A by auto + thus "submatrix A UNIV I' \ carrier_mat m k" using I'2 A unfolding submatrix_def by auto + qed + also have "... = (\J' | J' \ {0.. card J' = k. + det (submatrix P I J') * det (submatrix A J' I'))" + unfolding submatrix_split2[symmetric] submatrix_split[symmetric] by simp + finally show ?thesis . + qed + have "det (submatrix B I J) = det (submatrix (P*A*Q) I J)" using PAQ_B by simp + also have "... = det (?subPA * ?subQ)" unfolding submatrix_mult by auto + also have "... = (\I' | I' \ {0.. card I' = k. det (submatrix ?subPA UNIV I') + * det (submatrix ?subQ I' UNIV))" + by (rule Cauchy_Binet[OF subPA subQ]) + also have "... = (\I' | I' \ {0.. card I' = k. + det (submatrix (P * A) I I') * det (submatrix Q I' J))" + using submatrix_split[symmetric, of Q] submatrix_split2[symmetric, of "P*A"] by presburger + also have "... = (\I' | I' \ {0.. card I' = k. \J' | J' \ {0.. card J' = k. + det (submatrix P I J') * det (submatrix A J' I') * det (submatrix Q I' J))" + using det_subPA_rw by (simp add: semiring_0_class.sum_distrib_right) + finally have det_rw: "det (submatrix B I J) = (\I' | I' \ {0.. card I' = k. + \J' | J' \ {0.. card J' = k. + det (submatrix P I J') * det (submatrix A J' I') * det (submatrix Q I' J))" . + show ?thesis + proof (unfold det_rw, (rule dvd_sum)+) + fix I' J' + assume I': "I' \ {I'. I' \ {0.. card I' = k}" + and J': "J' \ {J'. J' \ {0.. card J' = k}" + have "Gcd (minors A k) dvd det (submatrix A J' I')" + by (rule Gcd_dvd, unfold minors_def, insert A I' J', auto) + then show "Gcd (minors A k) dvd det (submatrix P I J') * det (submatrix A J' I') + * det (submatrix Q I' J)" by auto + qed +qed + +(*The conclusion could be simplified since we have S = I.*) +lemma det_minors_diagonal2: + assumes dA: "diagonal_mat A" and A_carrier: "A \ carrier_mat n m" + and Ik: "card I = k" and Jk: "card J = k" + and r: "I \ {0.. {0..0" + shows "det (submatrix A I J) = 0 \ (\S. S \ {0.. card S = k \ S=I \ + (det (submatrix A I J) = (\i\S. A $$ (i,i)) \ det (submatrix A I J) = - (\i\S. A $$ (i,i))))" + using Ik Jk r c k +proof (induct k arbitrary: I J) + case 0 + then show ?case by auto +next + case (Suc k) + note cardI = Suc.prems(1) + note cardJ = Suc.prems(2) + note I = Suc.prems(3) + note J = Suc.prems(4) + have *: "{i. i < dim_row A \ i \ I} = I" using I Ik A_carrier carrier_mat_def by auto + have **: "{j. j < dim_col A \ j \ J} = J" using J Jk A_carrier carrier_mat_def by auto + show ?case + proof (cases "k = 0") + case True note k0 = True + from this obtain a where aI: "I = {a}" using True cardI card_1_singletonE by auto + from this obtain b where bJ: "J = {b}" using True cardJ card_1_singletonE by auto + have an: "a carrier_mat 1 1" + unfolding carrier_mat_def submatrix_def + using * ** aI bJ by auto + have 1: "det (submatrix A {a} {b}) = (submatrix A {a} {b}) $$ (0,0)" + by (rule det_singleton[OF sub_carrier]) + have 2: "... = A $$ (a,b)" + by (rule submatrix_singleton_index[OF A_carrier an bm]) + show ?thesis + proof (cases "A $$ (a,b) \ 0") + let ?S="{a}" + case True + hence ab: "a = b" using dA A_carrier an bm unfolding diagonal_mat_def carrier_mat_def by auto + hence "?S \ {0..i\?S. A $$ (i, i))" using 1 2 ab by auto + moreover have "card ?S = Suc k" using k0 by auto + ultimately show ?thesis using an bm unfolding aI bJ by blast + next + case False + then show ?thesis using 1 2 aI bJ by auto + qed + next + case False + hence k0: "0 < k" by simp + have k: "k < min n m" + by (metis I J cardI cardJ le_imp_less_Suc less_Suc_eq_le min.commute + min_def not_less subset_eq_atLeast0_lessThan_card) + have subIJ_carrier: "(submatrix A I J) \ carrier_mat (Suc k) (Suc k)" + unfolding carrier_mat_def using * ** cardI cardJ + unfolding submatrix_def by auto + obtain b' where b'k: "b' < Suc k" by auto + let ?f="\i. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b'" + have det_rw: "det (submatrix A I J) + = (\ia' 0") + case True + obtain a' where sub_IJ_0: "submatrix A I J $$ (a',b') \ 0" + and a'k: "a' < Suc k" + and unique: "\j. j submatrix A I J $$ (j,b') \ 0 \ j = a'" + using diagonal_imp_submatrix_element_not0[OF dA A_carrier cardI cardJ I J b'k True] by auto + have "submatrix A I J $$ (a', b') = A $$ (pick I a', pick J b')" + by (rule submatrix_index, auto simp add: "*" a'k cardI "**" b'k cardJ) + from this obtain a b where an: "a < n" and bm: "b < m" + and sub_index: "submatrix A I J $$ (a', b') = A $$ (a, b)" + and pick_a: "pick I a' = a" and pick_b: "pick J b' = b" + using * ** A_carrier a'k b'k cardI cardJ pick_le by fastforce + obtain I' where aI': "I = insert a I'" and a_notin: "a \ I'" + by (metis Set.set_insert a'k cardI pick_a pick_in_set_le) + obtain J' where bJ': "J = insert b J'" and b_notin: "b \ J'" + by (metis Set.set_insert b'k cardJ pick_b pick_in_set_le) + have Suc_k0: "0 < Suc k" by simp + have aI: "a \ I" using aI' by auto + have bJ: "b \ J" using bJ' by auto + have cardI': "card I' = k" + by (metis aI' a_notin cardI card_infinite card_insert_disjoint + finite_insert nat.inject nat.simps(3)) + have cardJ': "card J' = k" + by (metis bJ' b_notin cardJ card_infinite card_insert_disjoint + finite_insert nat.inject nat.simps(3)) + have I': "I' \ {0.. {0.. (\S\{0.. S=I' + \ (det (submatrix A I' J') = (\i\S. A $$ (i, i)) + \ det (submatrix A I' J') = - (\i\S. A $$ (i, i))))" + proof (rule Suc.hyps[OF cardI' cardJ' _ _ k0]) + show "I' \ {0.. {0..ii\xs. A $$ (i, i)) + \ det (submatrix A I' J') = - (\i\xs. A $$ (i, i))" + and xs: "xs\{0.. xs" + by (simp add: xs_I' a_notin) + have length_ys: "card ?ys = Suc k" + using length_xs a_notin_xs by (simp add: card_ge_0_finite k0) + have a_eq_b: "a=b" + using A_carrier an bm sub_IJ_0 sub_index dA unfolding diagonal_mat_def by auto + have A_aa_in: "A$$(a,a) \ {A $$ (i, i) |i. i < min n m \ A $$ (i, i) \ 0}" + using a_eq_b an bm sub_IJ_0 sub_index by auto + show ?thesis + proof (cases "even (a'+b')") + case True + have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * det (submatrix A I' J')" + using det_submatrix_IJ True by auto + show ?thesis + proof (cases "det (submatrix A I' J') = (\i\xs. A $$ (i, i))") + case True + have "det (submatrix A I J) = (\i\?ys. A $$ (i, i))" + using det_submatrix_IJ unfolding True a_eq_b + by (metis (no_types, lifting) a_notin_xs a_eq_b + card_ge_0_finite k0 length_xs prod.insert) + then show ?thesis using length_ys + using a_eq_b an bm xs xs_I' + by (simp add: aI') + next + case False + hence "det (submatrix A I' J') = - (\i\xs. A $$ (i, i))" using prod_list_xs by simp + hence "det (submatrix A I J) = -(\i\?ys. A $$ (i, i))" using det_submatrix_IJ a_eq_b + by (metis (no_types, lifting) a_notin_xs card_ge_0_finite k0 + length_xs mult_minus_right prod.insert) + then show ?thesis using length_ys + using a_eq_b an bm xs aI' xs_I' by force + qed + next + case False + have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * - det (submatrix A I' J')" + using det_submatrix_IJ False by auto + show ?thesis + proof (cases "det (submatrix A I' J') = (\i\xs. A $$ (i, i))") + case True + have "det (submatrix A I J) = - (\i\?ys. A $$ (i, i))" + using det_submatrix_IJ unfolding True + by (metis (no_types, lifting) a_eq_b a_notin_xs card_ge_0_finite k0 + length_xs mult_minus_right prod.insert) + then show ?thesis using length_ys + using a_eq_b an bm xs aI' xs_I' by force + next + case False + hence "det (submatrix A I' J') = - (\i\xs. A $$ (i, i))" using prod_list_xs by simp + hence "det (submatrix A I J) = (\i\?ys. A $$ (i, i))" using det_submatrix_IJ + by (metis (mono_tags, lifting) a_eq_b a_notin_xs card_ge_0_finite + equation_minus_iff k0 length_xs prod.insert) + then show ?thesis using length_ys + using a_eq_b an bm xs aI' xs_I' by force + qed + qed + qed + next + case False + have "sum ?f {0..Relating minors and GCD\ + +lemma diagonal_dvd_Gcd_minors: + fixes A::"'a::{semiring_Gcd,comm_ring_1} mat" + assumes A: "A \ carrier_mat n m" + and SNF_A: "Smith_normal_form_mat A" +shows "(\i=0.. minors A k" + show "(\i = 0.. {0.. {0.. {0..i\S. A $$ (i,i)) + \ det (submatrix A I J) = -(\i\S. A $$ (i,i))" + using det_minors_diagonal2[OF diag_A A Ik Jk _ _ k] I J A False b by auto + obtain f where inj_f: "inj_on f {0..i\{0.. f i)" using exists_inj_ge_index[OF S Sk] by blast + have "(\i = 0..i\{0..i\f`{0..i\S. A $$ (i, i))" using fk_S by auto + finally have *: "(\i = 0..i\S. A $$ (i, i))" . + show "(\i = 0.. carrier_mat n m" + and SNF_A: "Smith_normal_form_mat A" + and k: "k \ min n m" + shows "Gcd (minors A k) dvd (\i=0..i = 0..(i, j). A $$ (i, j))" + proof (rule eq_matI, auto) + have "I = {i. i < dim_row A \ i \ I}" unfolding I_def using A k by auto + hence ck: "card {i. i < dim_row A \ i \ I} = k" + unfolding I_def using card_atLeastLessThan by presburger + have "I = {i. i < dim_col A \ i \ I}" unfolding I_def using A k by auto + hence ck2: "card {j. j < dim_col A \ j \ I} = k" + unfolding I_def using card_atLeastLessThan by presburger + show dr: "dim_row (submatrix A I I) = k" using ck unfolding submatrix_def by auto + show dc: "dim_col (submatrix A I I) = k" using ck2 unfolding submatrix_def by auto + fix i j assume i: "i < k" and j: "j < k" + have p1: "pick I i = i" + proof - + have "{0.. I. a < i}" using I_def i by auto + hence i_eq: "i = card {a \ I. a < i}" + by (metis card_atLeastLessThan diff_zero) + have "pick I i = pick I (card {a \ I. a < i})" using i_eq by simp + also have "... = i" by (rule pick_card_in_set, insert i I_def, simp) + finally show ?thesis . + qed + have p2: "pick I j = j" + proof - + have "{0.. I. a < j}" using I_def j by auto + hence j_eq: "j = card {a \ I. a < j}" + by (metis card_atLeastLessThan diff_zero) + have "pick I j = pick I (card {a \ I. a < j})" using j_eq by simp + also have "... = j" by (rule pick_card_in_set, insert j I_def, simp) + finally show ?thesis . + qed + have "submatrix A I I $$ (i, j) = A $$ (pick I i, pick I j)" + proof (rule submatrix_index) + show "i < card {i. i < dim_row A \ i \ I}" by (metis dim_submatrix(1) dr i) + show "j < card {j. j < dim_col A \ j \ I}" by (metis dim_submatrix(2) dc j) + qed + also have "... = A $$ (i,j)" using p1 p2 by simp + finally show "submatrix A I I $$ (i, j) = A $$ (i, j)" . + qed + hence "det (submatrix A I I) = det (mat k k (\(i, j). A $$ (i, j)))" by simp + also have "... = prod_list (diag_mat (mat k k (\(i, j). A $$ (i, j))))" + proof (rule det_upper_triangular) + show "mat k k (\(i, j). A $$ (i, j)) \ carrier_mat k k" by auto + show "upper_triangular (Matrix.mat k k (\(i, j). A $$ (i, j)))" + using SNF_A A k unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto + qed + also have "... = (\i = 0.. {0.. {0..i = 0.. minors A k" unfolding minors_def by auto +qed + + + +lemma Gcd_minors_A_dvd_Gcd_minors_PAQ: + fixes A::"'a::{semiring_Gcd,comm_ring_1} mat" + assumes A: "A \ carrier_mat m n" + and P: "P \ carrier_mat m m" and Q: "Q \ carrier_mat n n" + shows "Gcd (minors A k) dvd Gcd (minors (P*A*Q) k)" +proof (rule Gcd_greatest) + let ?B="(P * A * Q)" + fix b assume "b \ minors ?B k" + from this obtain I J where b: "b = det (submatrix ?B I J)" and I: "I \ {0.. {0.. carrier_mat m n" + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and inv_P: "invertible_mat P" + and inv_Q: "invertible_mat Q" + shows "Gcd (minors (P*A*Q) k) dvd Gcd (minors A k)" +proof (rule Gcd_greatest) + let ?B = "P * A * Q" + fix b assume "b \ minors A k" + from this obtain I J where b: "b = det (submatrix A I J)" and I: "I \ {0.. {0.. carrier_mat m m" using PP' P'P unfolding inverts_mat_def + by (metis P carrier_matD(1) carrier_matD(2) carrier_matI index_mult_mat(3) index_one_mat(3)) + have Q': "Q' \ carrier_mat n n" + using QQ' Q'Q unfolding inverts_mat_def + by (metis Q carrier_matD(1) carrier_matD(2) carrier_matI index_mult_mat(3) index_one_mat(3)) + have rw: "P' *?B *Q' = A" + proof - + have f1: "P' * P = 1\<^sub>m m" + by (metis (no_types) P' P'P carrier_matD(1) inverts_mat_def) + have *: "P' * P * A = P' * (P * A)" + by (meson A P P' assoc_mult_mat) + have " P' * (P * A * Q) * Q' = P' * P * A * Q * Q'" + by (smt A P P' Q assoc_mult_mat mult_carrier_mat) + also have "... = P' * P * (A * Q * Q')" + using A P P' Q Q' f1 * by auto + also have "... = A * Q * Q'" using P'P A P' unfolding inverts_mat_def by auto + also have "... = A" using QQ' A Q' Q unfolding inverts_mat_def by auto + finally show ?thesis . + qed + have "Gcd (minors ?B k) dvd det (submatrix (P'*?B*Q') I J)" + by (rule Gcd_minors_dvd[OF _ P' _ Q' _ _ Ik Jk], insert P A Q I J, auto) + also have "... = det (submatrix A I J)" using rw by simp + finally show "Gcd (minors ?B k) dvd b" using b by simp +qed + +lemma Gcd_minors_dvd_diag_PAQ: + fixes P A Q::"'a::{semiring_Gcd,comm_ring_1} mat" + assumes A: "A \ carrier_mat m n" + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and SNF: "Smith_normal_form_mat (P*A*Q)" + and k: "k\min m n" + shows "Gcd (minors A k) dvd (\i=0..i=0.. carrier_mat m n" + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and inv_P: "invertible_mat P" + and inv_Q: "invertible_mat Q" + and SNF: "Smith_normal_form_mat (P*A*Q)" + shows "(\i=0..i=0.. carrier_mat m n" + and SNF: "Smith_normal_form_mat A" + and prod_0: "(\j=0..Final theorem\ + +lemma Smith_normal_form_uniqueness_aux: + fixes P A Q::"'a::{idom,semiring_Gcd} mat" + assumes A: "A \ carrier_mat m n" + (*PAQ = B with B in SNF and P,Q invertible matrices*) + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and inv_P: "invertible_mat P" + and inv_Q: "invertible_mat Q" + and PAQ_B: "P*A*Q = B" + and SNF: "Smith_normal_form_mat B" + (*P'AQ' = B' with B' in SNF and P',Q' invertible matrices*) + and P': "P' \ carrier_mat m m" + and Q': "Q' \ carrier_mat n n" + and inv_P': "invertible_mat P'" + and inv_Q': "invertible_mat Q'" + and P'AQ'_B': "P'*A*Q' = B'" + and SNF_B': "Smith_normal_form_mat B'" + and k: "ki\k. B$$(i,i) dvd B'$$(i,i) \ B'$$(i,i) dvd B$$(i,i)" +proof (rule allI, rule impI) + fix i assume ik: "i \ k" + show " B $$ (i, i) dvd B' $$ (i, i) \ B' $$ (i, i) dvd B $$ (i, i)" + proof - + let ?\Bi = "(\i=0..B'i = "(\i=0..B'i dvd Gcd (minors A i)" + by (unfold P'AQ'_B'[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P' Q' inv_P' inv_Q'], + insert P'AQ'_B' SNF_B' ik k, auto ) + also have "... dvd ?\Bi" + by (unfold PAQ_B[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P Q], + insert PAQ_B SNF ik k, auto) + finally have B'_i_dvd_B_i: "?\B'i dvd ?\Bi" . + have "?\Bi dvd Gcd (minors A i)" + by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q], + insert PAQ_B SNF ik k, auto ) + also have "... dvd ?\B'i" + by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'], + insert P'AQ'_B' SNF_B' ik k, auto) + finally have B_i_dvd_B'_i: "?\Bi dvd ?\B'i" . + let ?\B_Suc = "(\i=0..B'_Suc = "(\i=0..B'_Suc dvd Gcd (minors A (Suc i))" + by (unfold P'AQ'_B'[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P' Q' inv_P' inv_Q'], + insert P'AQ'_B' SNF_B' ik k, auto ) + also have "... dvd ?\B_Suc" + by (unfold PAQ_B[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P Q], + insert PAQ_B SNF ik k, auto) + finally have 3: "?\B'_Suc dvd ?\B_Suc" . + have "?\B_Suc dvd Gcd (minors A (Suc i))" + by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q], + insert PAQ_B SNF ik k, auto ) + also have "... dvd ?\B'_Suc" + by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'], + insert P'AQ'_B' SNF_B' ik k, auto) + finally have 4: "?\B_Suc dvd ?\B'_Suc" . + show ?thesis + proof (cases "?\B_Suc = 0") + case True + have True2: "?\B'_Suc = 0" using 4 True by fastforce + have "B$$(i,i) = 0" + by (rule Smith_prod_zero_imp_last_zero[OF _ SNF True], insert ik k PAQ_B P Q, auto) + moreover have "B'$$(i,i) = 0" + by (rule Smith_prod_zero_imp_last_zero[OF _ SNF_B' True2], + insert ik k P'AQ'_B' P' Q', auto) + ultimately show ?thesis by auto + next + case False + have "\u. u dvd 1 \ ?\B'i = u * ?\Bi" + by (rule dvd_associated2[OF B'_i_dvd_B_i B_i_dvd_B'_i], insert False B'_i_dvd_B_i, force) + from this obtain u where eq1: "(\i=0..i=0..u. u dvd 1 \ ?\B_Suc = u * ?\B'_Suc" + by (rule dvd_associated2[OF 4 3 False]) + from this obtain w where eq2: "(\i=0..i=0..i=0..i=0..i=0..i=0..i=0..u. is_unit u \ B $$ (i, i) = u * B' $$ (i, i)" by auto + thus ?thesis using dvd_associated2 by force + qed + qed +qed + + +lemma Smith_normal_form_uniqueness: + fixes P A Q::"'a::{idom,semiring_Gcd} mat" + assumes A: "A \ carrier_mat m n" + (*PAQ = B with B in SNF and P,Q invertible matrices*) + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and inv_P: "invertible_mat P" + and inv_Q: "invertible_mat Q" + and PAQ_B: "P*A*Q = B" + and SNF: "Smith_normal_form_mat B" + (*P'AQ' = B' with B' in SNF and P',Q' invertible matrices*) + and P': "P' \ carrier_mat m m" + and Q': "Q' \ carrier_mat n n" + and inv_P': "invertible_mat P'" + and inv_Q': "invertible_mat Q'" + and P'AQ'_B': "P'*A*Q' = B'" + and SNF_B': "Smith_normal_form_mat B'" + and i: "i < min m n" + shows "\u. u dvd 1 \ B $$ (i,i) = u * B' $$ (i,i)" +proof (cases "B $$ (i,i) = 0") + case True + let ?\B_Suc = "(\i=0..B'_Suc = "(\i=0..B_Suc dvd Gcd (minors A (Suc i))" + by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q], + insert PAQ_B SNF i, auto) + also have "... dvd ?\B'_Suc" + by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'], + insert P'AQ'_B' SNF_B' i, auto) + finally have 4: "?\B_Suc dvd ?\B'_Suc" . + have prod0: "?\B_Suc=0" using True by auto + have True2: "?\B'_Suc = 0" using 4 by (metis dvd_0_left_iff prod0) + have "B'$$(i,i) = 0" + by (rule Smith_prod_zero_imp_last_zero[OF _ SNF_B' True2], + insert i P'AQ'_B' P' Q', auto) + thus ?thesis using True by auto +next + case False + have "\a\i. B$$(a,a) dvd B'$$(a,a) \ B'$$(a,a) dvd B$$(a,a)" + by (rule Smith_normal_form_uniqueness_aux[OF assms]) + hence "B$$(i,i) dvd B'$$(i,i) \ B'$$(i,i) dvd B$$(i,i)" using i by auto + thus ?thesis using dvd_associated2 False by blast +qed + +text \The final theorem, moved to HOL Analysis\ + +lemma Smith_normal_form_uniqueness_HOL_Analysis: + fixes A::"'a::{idom,semiring_Gcd}^'m::mod_type^'n::mod_type" + and P P'::"'a^'n::mod_type^'n::mod_type" + and Q Q'::"'a^'m::mod_type^'m::mod_type" + assumes + (*PAQ = B with B in SNF and P,Q invertible matrices*) + inv_P: "invertible P" + and inv_Q: "invertible Q" + and PAQ_B: "P**A**Q = B" + and SNF: "Smith_normal_form B" + (*P'AQ' = B' with B' in SNF and P',Q' invertible matrices*) + and inv_P': "invertible P'" + and inv_Q': "invertible Q'" + and P'AQ'_B': "P'**A**Q' = B'" + and SNF_B': "Smith_normal_form B'" + and i: "i < min (nrows A) (ncols A)" + shows "\u. u dvd 1 \ B $h Mod_Type.from_nat i $h Mod_Type.from_nat i + = u * B' $h Mod_Type.from_nat i $h Mod_Type.from_nat i" +proof - + let ?P = "Mod_Type_Connect.from_hma\<^sub>m P" + let ?A = "Mod_Type_Connect.from_hma\<^sub>m A" + let ?Q = "Mod_Type_Connect.from_hma\<^sub>m Q" + let ?B = "Mod_Type_Connect.from_hma\<^sub>m B" + let ?P' = "Mod_Type_Connect.from_hma\<^sub>m P'" + let ?Q' = "Mod_Type_Connect.from_hma\<^sub>m Q'" + let ?B' = "Mod_Type_Connect.from_hma\<^sub>m B'" + let ?i = "(Mod_Type.from_nat i)::'n" + let ?i' = "(Mod_Type.from_nat i)::'m" + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?P P" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q Q" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B B" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?P' P'" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q'" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B' B'" by (simp add: Mod_Type_Connect.HMA_M_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i" + by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE + mod_type_class.to_nat_from_nat_id nrows_def) + have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" + by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE + mod_type_class.to_nat_from_nat_id ncols_def) + have i2: "i < min CARD('m) CARD('n)" using i unfolding nrows_def ncols_def by auto + have "\u. u dvd 1 \ ?B $$(i,i) = u * ?B' $$ (i,i)" + proof (rule Smith_normal_form_uniqueness[of _ "CARD('n)" "CARD('m)"]) + show "?P*?A*?Q=?B" using PAQ_B by (transfer', auto) + show "Smith_normal_form_mat ?B" using SNF by (transfer', auto) + show "?P'*?A*?Q'=?B'" using P'AQ'_B' by (transfer', auto) + show "Smith_normal_form_mat ?B'" using SNF_B' by (transfer', auto) + show "invertible_mat ?P" using inv_P by (transfer, auto) + show "invertible_mat ?P'" using inv_P' by (transfer, auto) + show "invertible_mat ?Q" using inv_Q by (transfer, auto) + show "invertible_mat ?Q'" using inv_Q' by (transfer, auto) + qed (insert i2, auto) + hence "\u. u dvd 1 \ (index_hma B ?i ?i') = u * (index_hma B' ?i ?i')" by (transfer', rule) + thus ?thesis unfolding index_hma_def by simp +qed + +subsection \Uniqueness fixing a complete set of non-associates\ + +definition "Smith_normal_form_wrt A \ = ( + (\a b. Mod_Type.to_nat a = Mod_Type.to_nat b \ Mod_Type.to_nat a + 1 < nrows A + \ Mod_Type.to_nat b + 1 < ncols A \ A $h a $h b dvd A $h (a+1) $h (b+1)) + \ isDiagonal A \ Complete_set_non_associates \ + \ (\a b. Mod_Type.to_nat a = Mod_Type.to_nat b \ Mod_Type.to_nat a < min (nrows A) (ncols A) + \ Mod_Type.to_nat b < min (nrows A) (ncols A) \ A $h a $h b \ \) + )" + +lemma Smith_normal_form_wrt_uniqueness_HOL_Analysis: + fixes A::"'a::{idom,semiring_Gcd}^'m::mod_type^'n::mod_type" + and P P'::"'a^'n::mod_type^'n::mod_type" + and Q Q'::"'a^'m::mod_type^'m::mod_type" + assumes + (*PAQ = S with S in SNF and P,Q invertible matrices*) + P: "invertible P" + and Q: "invertible Q" + and PAQ_S: "P**A**Q = S" + and SNF: "Smith_normal_form_wrt S \" + (*P'AQ' = S' with S' in SNF and P',Q' invertible matrices*) + and P': "invertible P'" + and Q': "invertible Q'" + and P'AQ'_S': "P'**A**Q' = S'" + and SNF_S': "Smith_normal_form_wrt S' \" + shows "S = S'" +proof - + have "S $h i $h j = S' $h i $h j" for i j + proof (cases "Mod_Type.to_nat i \ Mod_Type.to_nat j") + case True + then show ?thesis using SNF SNF_S' unfolding Smith_normal_form_wrt_def isDiagonal_def by auto + next + case False + let ?i = "Mod_Type.to_nat i" + let ?j = "Mod_Type.to_nat j" + have complete_set: "Complete_set_non_associates \" + using SNF_S' unfolding Smith_normal_form_wrt_def by simp + have ij: "?i = ?j" using False by auto + show ?thesis + proof (rule ccontr) + assume d: "S $h i $h j \ S' $h i $h j" + have n: "normalize (S $h i $h j) \ normalize (S' $h i $h j)" + proof (rule in_Ass_not_associated[OF complete_set _ _ d]) + show "S $h i $h j \ \" using SNF unfolding Smith_normal_form_wrt_def + by (metis False min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def) + show "S' $h i $h j \ \" using SNF_S' unfolding Smith_normal_form_wrt_def + by (metis False min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def) + qed + have "\u. u dvd 1 \ S $h i $h j = u * S' $h i $h j" + proof - + have "\u. u dvd 1 \ S $h Mod_Type.from_nat ?i $h Mod_Type.from_nat ?i + = u * S' $h Mod_Type.from_nat ?i $h Mod_Type.from_nat ?i" + proof (rule Smith_normal_form_uniqueness_HOL_Analysis[OF P Q PAQ_S _ P' Q' P'AQ'_S' _]) + show "Smith_normal_form S" and "Smith_normal_form S'" + using SNF SNF_S' Smith_normal_form_def Smith_normal_form_wrt_def by blast+ + show "?i < min (nrows A) (ncols A)" + by (metis ij min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def) + qed + thus ?thesis using False by auto + qed + from this obtain u where "is_unit u" and "S $h i $h j = u * S' $h i $h j" by auto + thus False using n + by (simp add: normalize_1_iff normalize_mult) + qed + qed + thus ?thesis by vector +qed + + +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/Smith_Certified.thy b/thys/Smith_Normal_Form/Smith_Certified.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Smith_Certified.thy @@ -0,0 +1,125 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \A certified checker based on an external algorithm to compute Smith normal form\ + +theory Smith_Certified + imports + SNF_Algorithm_Euclidean_Domain +begin + +text\This (unspecified) function takes as input the matrix $A$ and returns five matrices +$(P,S,Q,P',Q')$, which must satisfy $S = PAQ$, $S$ is in Smith normal form, $P'$ and $Q'$ +are the inverse matrices of $P$ and $Q$ respectively\ + +text\The matrices are given in terms of lists for the sake of simplicity when connecting the +function to external solvers, like Mathematica or Sage.\ + +consts external_SNF :: + "int list list \ int list list \ int list list \ int list list \ int list list \ int list list" + + +text \We implement the checker by means of the following definition. The checker is implemented +in the JNF representation of matrices to make use of the Strassen matrix multiplication algorithm. +In case that the certification fails, then the verified Smith normal form algorithm is executed. +Thus, we will always get a verified result.\ + +definition "checker_SNF A = ( + let A' = mat_to_list A; m = dim_row A; n = dim_col A in + case external_SNF A' of (P_ext,S_ext,Q_ext,P'_ext,Q'_ext) \ let + P = mat_of_rows_list m P_ext; + S = mat_of_rows_list m S_ext; + Q = mat_of_rows_list m Q_ext; + P' = mat_of_rows_list m P'_ext; + Q' = mat_of_rows_list m Q'_ext in + (if dim_row P = m \ dim_col P = m + \ dim_row S = m \ dim_col S = n + \ dim_row Q = n \ dim_col Q = n + \ dim_row P' = m \ dim_col P' = m + \ dim_row Q' = n \ dim_col Q' = n + \ P * P' = 1\<^sub>m m \ Q * Q' = 1\<^sub>m n + \ Smith_normal_form_mat S \ (S = P*A*Q) then + (P,S,Q) else Code.abort (STR ''Certification failed'') (\ _. Smith_ED_mxn A)) +)" + +theorem checker_SNF_soudness: + assumes A: "A \ carrier_mat m n" + and c: "checker_SNF A = (P,S,Q)" + shows "is_SNF A (P,S,Q)" +proof - + let ?ext = "external_SNF (mat_to_list A)" + obtain P_ext S_ext Q_ext P'_ext Q'_ext where ext: "?ext = (P_ext,S_ext,Q_ext,P'_ext,Q'_ext)" + by (cases "?ext", auto) + let ?case_external = "let + P = mat_of_rows_list m P_ext; + S = mat_of_rows_list m S_ext; + Q = mat_of_rows_list n Q_ext; + P' = mat_of_rows_list m P'_ext; + Q' = mat_of_rows_list n Q'_ext in + (dim_row P = m \ dim_col P = m + \ dim_row S = m \ dim_col S = n + \ dim_row Q = n \ dim_col Q = n + \ dim_row P' = m \ dim_col P' = m + \ dim_row Q' = n \ dim_col Q' = n + \ P * P' = 1\<^sub>m m \ Q * Q' = 1\<^sub>m n + \ Smith_normal_form_mat S \ (S = P*A*Q))" + show ?thesis + proof (cases ?case_external) + case True + define P' where "P' = mat_of_rows_list m P'_ext" + define Q' where "Q' = mat_of_rows_list m Q'_ext" + have S_PAQ: "S = P * A * Q " + and SNF_S: "Smith_normal_form_mat S" and PP'_1: "P * P' = 1\<^sub>m m" and QQ'_1: "Q * Q' = 1\<^sub>m n" + and sm_P: "square_mat P" and sm_Q: "square_mat Q" + using ext True c A + unfolding checker_SNF_def Let_def mat_of_rows_list_def P'_def Q'_def + by (auto split: if_splits) + have inv_P: "invertible_mat P" + proof (unfold invertible_mat_def, rule conjI, rule sm_P, + unfold inverts_mat_def, rule exI[of _ P'], rule conjI) + show *: "P * P' = 1\<^sub>m (dim_row P)" + by (metis PP'_1 True index_mult_mat(2)) + show "P' * P = 1\<^sub>m (dim_row P')" + proof (rule mat_mult_left_right_inverse) + show "P \ carrier_mat (dim_row P') (dim_row P')" + by (metis * P'_def PP'_1 True carrier_mat_triv index_one_mat(2) sm_P square_mat.elims(2)) + show "P' \ carrier_mat (dim_row P') (dim_row P')" + by (metis P'_def True carrier_mat_triv) + show "P * P' = 1\<^sub>m (dim_row P')" + by (metis P'_def PP'_1 True) + qed + qed + have inv_Q: "invertible_mat Q" + proof (unfold invertible_mat_def, rule conjI, rule sm_Q, + unfold inverts_mat_def, rule exI[of _ Q'], rule conjI) + show *: "Q * Q' = 1\<^sub>m (dim_row Q)" + by (metis QQ'_1 True index_mult_mat(2)) + show "Q' * Q = 1\<^sub>m (dim_row Q')" + proof (rule mat_mult_left_right_inverse) + show 1: "Q \ carrier_mat (dim_row Q') (dim_row Q')" + by (metis Q'_def QQ'_1 True carrier_mat_triv dim_row_mat(1) index_mult_mat(2) + mat_of_rows_list_def sm_Q square_mat.simps) + thus "Q' \ carrier_mat (dim_row Q') (dim_row Q')" + by (metis * carrier_matD(1) carrier_mat_triv index_mult_mat(3) index_one_mat(3)) + show "Q * Q' = 1\<^sub>m (dim_row Q')" using * 1 by auto + qed + qed + have "P \ carrier_mat m m" + by (metis PP'_1 True carrier_matI index_mult_mat(2) sm_P square_mat.simps) + moreover have "Q \ carrier_mat n n" + by (metis QQ'_1 True carrier_matI index_mult_mat(2) sm_Q square_mat.simps) + ultimately show ?thesis unfolding is_SNF_def using inv_P inv_Q SNF_S S_PAQ A by auto + next + case False + hence "checker_SNF A = Smith_ED_mxn A" + using ext False c A + unfolding checker_SNF_def Let_def Code.abort_def + by (smt carrier_matD case_prod_conv dim_col_mat(1) mat_of_rows_list_def) + then show ?thesis using Smith_ED.is_SNF_Smith_mxn[OF A] c unfolding is_SNF_def + by auto + qed +qed + +end diff --git a/thys/Smith_Normal_Form/Smith_Normal_Form.thy b/thys/Smith_Normal_Form/Smith_Normal_Form.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Smith_Normal_Form.thy @@ -0,0 +1,128 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Definition of Smith normal form in HOL Analysis\ + +theory Smith_Normal_Form + imports + Hermite.Hermite +begin + + +subsection \Definitions\ + +text\Definition of diagonal matrix\ + +definition "isDiagonal_upt_k A k = (\ a b. (to_nat a \ to_nat b \ (to_nat a < k \ (to_nat b < k))) \ A $ a $ b = 0)" +definition "isDiagonal A = (\ a b. to_nat a \ to_nat b \ A $ a $ b = 0)" + +lemma isDiagonal_intro: + fixes A::"'a::{zero}^'cols::mod_type^'rows::mod_type" + assumes "\a::'rows. \b::'cols. to_nat a = to_nat b" + shows "isDiagonal A" + using assms + unfolding isDiagonal_def by auto + +text\Definition of Smith normal form up to position k. The element $A_{k-1,k-1}$ +does not need to divide $A_{k,k}$ and $A_{k,k}$ could have non-zero entries above and below.\ + + definition "Smith_normal_form_upt_k A k = + ( + (\a b. to_nat a = to_nat b \ to_nat a + 1 < k \ to_nat b + 1< k \ A $ a $ b dvd A $ (a+1) $ (b+1)) + \ isDiagonal_upt_k A k + )" + +definition "Smith_normal_form A = + ( + (\a b. to_nat a = to_nat b \ to_nat a + 1 < nrows A \ to_nat b + 1 < ncols A \ A $ a $ b dvd A $ (a+1) $ (b+1)) + \ isDiagonal A + )" + +subsection \Basic properties\ + +lemma Smith_normal_form_min: + "Smith_normal_form A = Smith_normal_form_upt_k A (min (nrows A) (ncols A))" + unfolding Smith_normal_form_def Smith_normal_form_upt_k_def nrows_def ncols_def + unfolding isDiagonal_upt_k_def isDiagonal_def + by (auto, smt Suc_le_eq le_trans less_le min.boundedI not_less_eq_eq suc_not_zero + to_nat_less_card to_nat_plus_one_less_card') + + +lemma Smith_normal_form_upt_k_0[simp]: "Smith_normal_form_upt_k A 0" + unfolding Smith_normal_form_upt_k_def + unfolding isDiagonal_upt_k_def isDiagonal_def + by auto + +lemma Smith_normal_form_upt_k_intro: + assumes "(\a b. to_nat a = to_nat b \ to_nat a + 1 < k \ to_nat b + 1< k \ A $ a $ b dvd A $ (a+1) $ (b+1))" + and "(\a b. (to_nat a \ to_nat b \ (to_nat a < k \ (to_nat b < k))) \ A $ a $ b = 0)" +shows "Smith_normal_form_upt_k A k" + unfolding Smith_normal_form_upt_k_def + unfolding isDiagonal_upt_k_def isDiagonal_def using assms by simp + +lemma Smith_normal_form_upt_k_intro_alt: + assumes "(\a b. to_nat a = to_nat b \ to_nat a + 1 < k \ to_nat b + 1 < k \ A $ a $ b dvd A $ (a+1) $ (b+1))" + and "isDiagonal_upt_k A k" + shows "Smith_normal_form_upt_k A k" + using assms + unfolding Smith_normal_form_upt_k_def by auto + +lemma Smith_normal_form_upt_k_condition1: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes "Smith_normal_form_upt_k A k" + and "to_nat a = to_nat b" and " to_nat a + 1 < k" and "to_nat b + 1 < k " + shows "A $ a $ b dvd A $ (a+1) $ (b+1)" + using assms unfolding Smith_normal_form_upt_k_def by auto + + +lemma Smith_normal_form_upt_k_condition2: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes "Smith_normal_form_upt_k A k" + and "to_nat a \ to_nat b" and "(to_nat a < k \ to_nat b < k)" + shows "((A $ a) $ b) = 0" + using assms unfolding Smith_normal_form_upt_k_def + unfolding isDiagonal_upt_k_def isDiagonal_def by auto + + +lemma Smith_normal_form_upt_k1_intro: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes s: "Smith_normal_form_upt_k A k" + and cond1: "A $ from_nat (k - 1) $ from_nat (k-1) dvd A $ (from_nat k) $ (from_nat k)" + and cond2a: "\a. to_nat a > k \ A $ a $ from_nat k = 0" + and cond2b: "\b. to_nat b > k \ A $ from_nat k $ b = 0" +shows "Smith_normal_form_upt_k A (Suc k)" +proof (rule Smith_normal_form_upt_k_intro) + fix a::'rows and b::'cols + assume a: "to_nat a \ to_nat b \ (to_nat a < Suc k \ to_nat b < Suc k)" + show "A $ a $ b = 0" + by (metis Smith_normal_form_upt_k_condition2 a + assms(1) cond2a cond2b from_nat_to_nat_id less_SucE nat_neq_iff) +next + fix a::'rows and b::'cols + assume a: "to_nat a = to_nat b \ to_nat a + 1 < Suc k \ to_nat b + 1 < Suc k" + show "A $ a $ b dvd A $ (a + 1) $ (b + 1)" + by (metis (mono_tags, lifting) Smith_normal_form_upt_k_condition1 a add_diff_cancel_right' cond1 + from_nat_suc from_nat_to_nat_id less_SucE s) +qed + +lemma Smith_normal_form_upt_k1_intro_diagonal: + fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" + assumes s: "Smith_normal_form_upt_k A k" + and d: "isDiagonal A" + and cond1: "A $ from_nat (k - 1) $ from_nat (k-1) dvd A $ (from_nat k) $ (from_nat k)" +shows "Smith_normal_form_upt_k A (Suc k)" +proof (rule Smith_normal_form_upt_k_intro) + fix a::'rows and b::'cols + assume a: "to_nat a = to_nat b \ to_nat a + 1 < Suc k \ to_nat b + 1 < Suc k" + show "A $ a $ b dvd A $ (a + 1) $ (b + 1)" + by (metis (mono_tags, lifting) Smith_normal_form_upt_k_condition1 a + add_diff_cancel_right' cond1 from_nat_suc from_nat_to_nat_id less_SucE s) +next + show "\a b. to_nat a \ to_nat b \ (to_nat a < Suc k \ to_nat b < Suc k) \ A $ a $ b = 0" + using d isDiagonal_def by blast +qed + + +end \ No newline at end of file diff --git a/thys/Smith_Normal_Form/Smith_Normal_Form_JNF.thy b/thys/Smith_Normal_Form/Smith_Normal_Form_JNF.thy new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/Smith_Normal_Form_JNF.thy @@ -0,0 +1,168 @@ +(* + Author: Jose Divasón + Email: jose.divason@unirioja.es +*) + +section \Definition of Smith normal form in JNF\ + +theory Smith_Normal_Form_JNF + imports + SNF_Missing_Lemmas +begin + +text \Now, we define diagonal matrices and Smith normal form in JNF\ + +definition "isDiagonal_mat A = (\i j. i \ j \ i < dim_row A \ j < dim_col A \ A$$(i,j) = 0)" + +definition "Smith_normal_form_mat A = + ( + (\a. a + 1 < min (dim_row A) (dim_col A) \ A $$ (a,a) dvd A $$ (a+1,a+1)) + \ isDiagonal_mat A + )" + +lemma SNF_first_divides: + assumes SNF_A: "Smith_normal_form_mat A" and "(A::('a::comm_ring_1) mat) \ carrier_mat n m" + and i: "i < min (dim_row A) (dim_col A)" +shows "A $$ (0,0) dvd A $$ (i,i)" + using i +proof (induct i) + case 0 + then show ?case by auto +next + case (Suc i) + show ?case + by (metis (full_types) Smith_normal_form_mat_def Suc.hyps Suc.prems + Suc_eq_plus1 Suc_lessD SNF_A dvd_trans) +qed + +lemma Smith_normal_form_mat_intro: + assumes "(\a. a + 1 < min (dim_row A) (dim_col A) \ A $$ (a,a) dvd A $$ (a+1,a+1))" + and "isDiagonal_mat A" + shows "Smith_normal_form_mat A" + unfolding Smith_normal_form_mat_def using assms by auto + +lemma Smith_normal_form_mat_m0[simp]: + assumes A: "A\carrier_mat m 0" + shows "Smith_normal_form_mat A" + using A unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto + +lemma Smith_normal_form_mat_0m[simp]: + assumes A: "A\carrier_mat 0 m" + shows "Smith_normal_form_mat A" + using A unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto + +lemma S00_dvd_all_A: + assumes A: "(A::'a::comm_ring_1 mat) \ carrier_mat m n" + and P: "P \ carrier_mat m m" + and Q: "Q \ carrier_mat n n" + and inv_P: "invertible_mat P" + and inv_Q: "invertible_mat Q" + and S_PAQ: "S = P*A*Q" + and SNF_S: "Smith_normal_form_mat S" + and i: "ii j. i j S$$(0,0) dvd S$$(i,j))" + using SNF_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def + by (smt P Q SNF_first_divides A S_PAQ SNF_S carrier_matD + dvd_0_right min_less_iff_conj mult_carrier_mat) + obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P" + using inv_P unfolding invertible_mat_def by auto + obtain Q' where QQ': "inverts_mat Q Q'" and Q'Q: "inverts_mat Q' Q" + using inv_Q unfolding invertible_mat_def by auto + have A_P'SQ': "P'*S*Q' = A" + proof - + have "P'*S*Q' = P'*(P*A*Q)*Q'" unfolding S_PAQ by auto + also have "... = (P'*P)*A*(Q*Q')" + by (smt A PP' Q Q'Q P assoc_mult_mat carrier_mat_triv index_mult_mat(2) index_mult_mat(3) + index_one_mat(3) inverts_mat_def right_mult_one_mat) + also have "... = A" + by (metis A P'P QQ' A Q P carrier_matD(1) index_mult_mat(3) index_one_mat(3) inverts_mat_def + left_mult_one_mat right_mult_one_mat) + finally show ?thesis . + qed + have "(\i j. i j S$$(0,0) dvd (P'*S*Q')$$(i,j))" + proof (rule dvd_elements_mult_matrix_left_right[OF _ _ _ S00]) + show "S \ carrier_mat m n" using P A Q S_PAQ by auto + show "P' \ carrier_mat m m" + by (metis (mono_tags, lifting) A_P'SQ' PP' P A carrier_matD carrier_matI index_mult_mat(2) + index_mult_mat(3) inverts_mat_def one_carrier_mat) + show "Q' \ carrier_mat n n" + by (metis (mono_tags, lifting) A_P'SQ' Q'Q Q A carrier_matD(2) carrier_matI + index_mult_mat(3) inverts_mat_def one_carrier_mat) + qed + thus ?thesis using A_P'SQ' i j by auto +qed + + +lemma SNF_first_divides_all: + assumes SNF_A: "Smith_normal_form_mat A" and A: "(A::('a::comm_ring_1) mat) \ carrier_mat m n" + and i: "i < m" and j: "j carrier_mat n m" + and SNF_A: "Smith_normal_form_mat A" + and j: "j < min n m" + and ij: "i\j" + shows "A$$(i,i) dvd A$$(j,j)" + using ij j +proof (induct j) + case 0 + then show ?case by auto +next + case (Suc j) + show ?case + proof (cases "i\j") + case True + have "A $$ (i, i) dvd A $$ (j, j)" using Suc.hyps Suc.prems True by simp + also have "... dvd A $$ (Suc j, Suc j)" + using SNF_A Suc.prems A + unfolding Smith_normal_form_mat_def by auto + finally show ?thesis by auto + next + case False + hence "i=Suc j" using Suc.prems by auto + then show ?thesis by auto + qed +qed + +lemma Smith_zero_imp_zero: + fixes A::"'a::comm_ring_1 mat" + assumes A: "A \ carrier_mat m n" + and SNF: "Smith_normal_form_mat A" + and Aii: "A$$(i,i) = 0" + and j: "jj" + shows "A$$(j,j) = 0" +proof - + have "A$$(i,i) dvd A$$(j,j)" by (rule SNF_divides_diagonal[OF A SNF j ij]) + thus ?thesis using Aii by auto +qed + +lemma SNF_preserved_multiples_identity: + assumes S: "S \ carrier_mat m n" and SNF: "Smith_normal_form_mat (S::'a::comm_ring_1 mat)" + shows "Smith_normal_form_mat (S*(k \\<^sub>m 1\<^sub>m n))" +proof (rule Smith_normal_form_mat_intro) + have rw: "S*(k \\<^sub>m 1\<^sub>m n) = Matrix.mat m n (\(i, j). S $$ (i, j) * k)" + unfolding mat_diag_smult[symmetric] by (rule mat_diag_mult_right[OF S]) + show "isDiagonal_mat (S * (k \\<^sub>m 1\<^sub>m n))" + using SNF S unfolding Smith_normal_form_mat_def isDiagonal_mat_def rw + by auto + show "\a. a + 1 < min (dim_row (S * (k \\<^sub>m 1\<^sub>m n))) (dim_col (S * (k \\<^sub>m 1\<^sub>m n))) \ + (S * (k \\<^sub>m 1\<^sub>m n)) $$ (a, a) dvd (S * (k \\<^sub>m 1\<^sub>m n)) $$ (a + 1, a + 1)" + using SNF S unfolding Smith_normal_form_mat_def isDiagonal_mat_def rw + by (auto simp add: mult_dvd_mono) +qed + +end diff --git a/thys/Smith_Normal_Form/document/root.tex b/thys/Smith_Normal_Form/document/root.tex new file mode 100644 --- /dev/null +++ b/thys/Smith_Normal_Form/document/root.tex @@ -0,0 +1,73 @@ +\documentclass[11pt,a4paper]{article} +\usepackage{isabelle,isabellesym} + +% further packages required for unusual symbols (see also +% isabellesym.sty), use only when needed + +%\usepackage{amssymb} + %for \, \, \, \, \, \, + %\, \, \, \, \, + %\, \, \ + +%\usepackage{eurosym} + %for \ + +%\usepackage[only,bigsqcap]{stmaryrd} + %for \ + +%\usepackage{eufrak} + %for \ ... \, \ ... \ (also included in amssymb) + +%\usepackage{textcomp} + %for \, \, \, \, \, + %\ + +% this should be the last package used +\usepackage{pdfsetup} + +% urls in roman style, theory text in math-similar italics +\urlstyle{rm} +\isabellestyle{it} + +% for uniform font size +%\renewcommand{\isastyle}{\isastyleminor} + + +\begin{document} + +\title{A verified algorithm for computing the Smith normal form of a matrix} +\author{Jose Divas\'on} +\maketitle + +\begin{abstract} +This work presents a formal proof in Isabelle/HOL of an algorithm +to transform a matrix into its Smith normal form, a canonical +matrix form, in a general setting: the algorithm is parameterized by +operations to prove its existence over elementary divisor rings, while execution +is guaranteed over Euclidean domains. We also provide a formal proof +on some results about the generality of this algorithm as well as the +uniqueness of the Smith normal form. + +Since Isabelle/HOL does not feature dependent types, the development is carried out switching conveniently between two different +existing libraries: the Hermite normal form (based on HOL Analysis) and the Jordan normal form AFP entries. This permits to reuse results from both developments and it is done by means of the lifting and transfer package together with the use of local type definitions. +\end{abstract} + + +\tableofcontents + +% sane default for proof documents +\parindent 0pt\parskip 0.5ex + +% generated text of all theories +\input{session} + +% optional bibliography +%\bibliographystyle{abbrv} +%\bibliography{root} + +\end{document} + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: t +%%% End: