diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,994 +1,997 @@ For the purposes of the license agreement in the file COPYRIGHT, a 'contributor' is anybody who is listed in this file (CONTRIBUTORS) or who is listed as an author in one of the source files of this Isabelle distribution. Contributions to this Isabelle version -------------------------------------- * November 2020: Florian Haftmann Bundle mixins for locale and class expressions. +* November 2020: Jakub Kądziołka + Stronger lemmas about orders of group elements (generate_pow_card) + * October 2020: Jasmin Blanchette, Martin Desharnais, Mathias Fleury Use veriT in proof preplay in Sledgehammer. * October 2020: Mathias Fleury Updated proof reconstruction for the SMT solver veriT in the smt method. * October 2020: Jasmin Blanchette, Martin Desharnais Integration of E 2.5 for Sledgehammer. * September 2020: Florian Haftmann Substantial reworking and modularization of Word library, with generic type conversions. * August 2020: Makarius Wenzel Improved monitoring of runtime statistics: ML GC progress and Java. * July 2020: Martin Desharnais Integration of Metis 2.4. * June 2020: Makarius Wenzel Batch-builds via "isabelle build" allow to invoke Scala from ML. * June 2020: Florian Haftmann Simproc defined_all for more aggressive substitution with variables from assumptions. * May 2020: Makarius Wenzel Antiquotations for Isabelle systems programming, notably @{scala_function} and @{scala} to invoke Scala from ML. * May 2020: Florian Haftmann Generic algebraically founded bit operations NOT, AND, OR, XOR. Contributions to Isabelle2020 ----------------------------- * February 2020: E. Gunther, M. Pagano and P. Sánchez Terraf Simplified, generalised version of ZF/Constructible. * January 2020: LC Paulson The full finite Ramsey's theorem and elements of finite and infinite Ramsey theory. * December 2019: Basil Fürer, Andreas Lochbihler, Joshua Schneider, Dmitriy Traytel Extension of lift_bnf to support quotient types. * November 2019: Peter Zeller, TU Kaiserslautern Update of Isabelle/VSCode to WebviewPanel API. * October..December 2019: Makarius Wenzel Isabelle/Phabrictor server setup, including Linux platform support in Isabelle/Scala. Client-side tool "isabelle hg_setup". * October 2019: Maximilian Schäffeler Port of the HOL Light decision procedure for metric spaces. * October 2019: Makarius Wenzel More scalable Isabelle dump and underlying headless PIDE session. * August 2019: Makarius Wenzel Better support for proof terms in Isabelle/Pure, notably via method combinator SUBPROOFS (ML) and "subproofs" (Isar). * July 2019: Alexander Krauss, Makarius Wenzel Minimal support for a soft-type system within the Isabelle logical framework. Contributions to Isabelle2019 ----------------------------- * April 2019: LC Paulson Homology and supporting lemmas on topology and group theory * April 2019: Paulo de Vilhena and Martin Baillon Group theory developments, esp. algebraic closure of a field * February/March 2019: Makarius Wenzel Stateless management of export artifacts in the Isabelle/HOL code generator. * February 2019: Manuel Eberl Exponentiation by squaring, used to implement "power" in monoid_mult and fast modular exponentiation. * February 2019: Manuel Eberl Carmichael's function, primitive roots in residue rings, more properties of the order in residue rings. * February 2019: Jeremy Sylvestre Formal Laurent Series and overhaul of Formal power series. * January 2019: Florian Haftmann Clarified syntax and congruence rules for big operators on sets involving the image operator. * January 2019: Florian Haftmann Renovation of code generation, particularly export into session data and proper strings and proper integers based on zarith for OCaml. * January 2019: Andreas Lochbihler New implementation for case_of_simps based on Code_Lazy's pattern matching elimination algorithm. * November/December 2018: Makarius Wenzel Support for Isabelle/Haskell applications of Isabelle/PIDE. * August/September 2018: Makarius Wenzel Improvements of headless Isabelle/PIDE session and server, and systematic exports from theory documents. * December 2018: Florian Haftmann Generic executable sorting algorithms based on executable comparators. * October 2018: Mathias Fleury Proof reconstruction for the SMT solver veriT in the smt method. Contributions to Isabelle2018 ----------------------------- * July 2018: Manuel Eberl "real_asymp" proof method for automatic proofs of real limits, "Big-O" statements, etc. * June 2018: Fabian Immler More tool support for HOL-Types_To_Sets. * June 2018: Martin Baillon and Paulo Emílio de Vilhena A variety of contributions to HOL-Algebra. * June 2018: Wenda Li New/strengthened results involving analysis, topology, etc. * May/June 2018: Makarius Wenzel System infrastructure to export blobs as theory presentation, and to dump PIDE database content in batch mode. * May 2018: Manuel Eberl Landau symbols and asymptotic equivalence (moved from the AFP). * May 2018: Jose Divasón (Universidad de la Rioja), Jesús Aransay (Universidad de la Rioja), Johannes Hölzl (VU Amsterdam), Fabian Immler (TUM) Generalizations in the formalization of linear algebra. * May 2018: Florian Haftmann Consolidation of string-like types in HOL. * May 2018: Andreas Lochbihler (Digital Asset), Pascal Stoop (ETH Zurich) Code generation with lazy evaluation semantics. * March 2018: Florian Haftmann Abstract bit operations push_bit, take_bit, drop_bit, alongside with an algebraic foundation for bit strings and word types in HOL-ex. * March 2018: Viorel Preoteasa Generalisation of complete_distrib_lattice * February 2018: Wenda Li A unified definition for the order of zeros and poles. Improved reasoning around non-essential singularities. * January 2018: Sebastien Gouezel Various small additions to HOL-Analysis * December 2017: Jan Gilcher, Andreas Lochbihler, Dmitriy Traytel A new conditional parametricity prover. * October 2017: Alexander Maletzky Derivation of axiom "iff" in theory HOL.HOL from the other axioms. Contributions to Isabelle2017 ----------------------------- * September 2017: Lawrence Paulson HOL-Analysis, e.g. simplicial complexes, Jordan Curve Theorem. * September 2017: Jasmin Blanchette Further integration of Nunchaku model finder. * November 2016 - June 2017: Makarius Wenzel New Isabelle/VSCode, with underlying restructuring of Isabelle/PIDE. * 2017: Makarius Wenzel Session-qualified theory names (theory imports and ROOT files). Prover IDE improvements. Support for SQL databases in Isabelle/Scala: SQLite and PostgreSQL. * August 2017: Andreas Lochbihler, ETH Zurich type of unordered pairs (HOL-Library.Uprod) * August 2017: Manuel Eberl, TUM HOL-Analysis: infinite products over natural numbers, infinite sums over arbitrary sets, connection between formal power series and analytic complex functions * March 2017: Alasdair Armstrong, University of Sheffield and Simon Foster, University of York Fixed-point theory and Galois Connections in HOL-Algebra. * February 2017: Florian Haftmann, TUM Statically embedded computations implemented by generated code. Contributions to Isabelle2016-1 ------------------------------- * December 2016: Ondřej Kunčar, TUM Types_To_Sets: experimental extension of Higher-Order Logic to allow translation of types to sets. * October 2016: Jasmin Blanchette Integration of Nunchaku model finder. * October 2016: Jaime Mendizabal Roche, TUM Ported remaining theories of session Old_Number_Theory to the new Number_Theory and removed Old_Number_Theory. * September 2016: Sascha Boehme Proof method "argo" based on SMT technology for a combination of quantifier-free propositional logic, equality and linear real arithmetic * July 2016: Daniel Stuewe Height-size proofs in HOL-Data_Structures. * July 2016: Manuel Eberl, TUM Algebraic foundation for primes; generalization from nat to general factorial rings. * June 2016: Andreas Lochbihler, ETH Zurich Formalisation of discrete subprobability distributions. * June 2016: Florian Haftmann, TUM Improvements to code generation: optional timing measurements, more succint closures for static evaluation, less ambiguities concering Scala implicits. * May 2016: Manuel Eberl, TUM Code generation for Probability Mass Functions. * March 2016: Florian Haftmann, TUM Abstract factorial rings with unique factorization. * March 2016: Florian Haftmann, TUM Reworking of the HOL char type as special case of a finite numeral type. * March 2016: Andreas Lochbihler, ETH Zurich Reasoning support for monotonicity, continuity and admissibility in chain-complete partial orders. * February - October 2016: Makarius Wenzel Prover IDE improvements. ML IDE improvements: bootstrap of Pure. Isar language consolidation. Notational modernization of HOL. Tight Poly/ML integration. More Isabelle/Scala system programming modules (e.g. SSH, Mercurial). * Winter 2016: Jasmin Blanchette, Inria & LORIA & MPII, Aymeric Bouzy, Ecole polytechnique, Andreas Lochbihler, ETH Zurich, Andrei Popescu, Middlesex University, and Dmitriy Traytel, ETH Zurich 'corec' command and friends. * January 2016: Florian Haftmann, TUM Abolition of compound operators INFIMUM and SUPREMUM for complete lattices. Contributions to Isabelle2016 ----------------------------- * Winter 2016: Manuel Eberl, TUM Support for real exponentiation ("powr") in the "approximation" method. (This was removed in Isabelle 2015 due to a changed definition of "powr".) * Summer 2015 - Winter 2016: Lawrence C Paulson, Cambridge General, homology form of Cauchy's integral theorem and supporting material (ported from HOL Light). * Winter 2015/16: Gerwin Klein, NICTA New print_record command. * May - December 2015: Makarius Wenzel Prover IDE improvements. More Isar language elements. Document language refinements. Poly/ML debugger integration. Improved multi-platform and multi-architecture support. * Winter 2015: Manuel Eberl, TUM The radius of convergence of power series and various summability tests. Harmonic numbers and the Euler-Mascheroni constant. The Generalised Binomial Theorem. The complex and real Gamma/log-Gamma/Digamma/Polygamma functions and their most important properties. * Autumn 2015: Manuel Eberl, TUM Proper definition of division (with remainder) for formal power series; Euclidean Ring and GCD instance for formal power series. * Autumn 2015: Florian Haftmann, TUM Rewrite definitions for global interpretations and sublocale declarations. * Autumn 2015: Andreas Lochbihler Bourbaki-Witt fixpoint theorem for increasing functions on chain-complete partial orders. * Autumn 2015: Chaitanya Mangla, Lawrence C Paulson, and Manuel Eberl A large number of additional binomial identities. * Summer 2015: Daniel Matichuk, NICTA and Makarius Wenzel Isar subgoal command for proof structure within unstructured proof scripts. * Summer 2015: Florian Haftmann, TUM Generic partial division in rings as inverse operation of multiplication. * Summer 2015: Manuel Eberl and Florian Haftmann, TUM Type class hierarchy with common algebraic notions of integral (semi)domains like units, associated elements and normalization wrt. units. * Summer 2015: Florian Haftmann, TUM Fundamentals of abstract type class for factorial rings. * Summer 2015: Julian Biendarra, TUM and Dmitriy Traytel, ETH Zurich Command to lift a BNF structure on the raw type to the abstract type for typedefs. * Summer 2014: Jeremy Avigad, Luke Serafin, CMU, and Johannes Hölzl, TUM Proof of the central limit theorem: includes weak convergence, characteristic functions, and Levy's uniqueness and continuity theorem. Contributions to Isabelle2015 ----------------------------- * 2014/2015: Daniel Matichuk, Toby Murray, NICTA and Makarius Wenzel The Eisbach proof method language and "match" method. * Winter 2014 and Spring 2015: Ondrej Kuncar, TUM Extension of lift_definition to execute lifted functions that have as a return type a datatype containing a subtype. * March 2015: Jasmin Blanchette, Inria & LORIA & MPII, Mathias Fleury, MPII, and Dmitriy Traytel, TUM More multiset theorems, syntax, and operations. * December 2014: Johannes Hölzl, Manuel Eberl, Sudeep Kanav, TUM, and Jeremy Avigad, Luke Serafin, CMU Various integration theorems: mostly integration on intervals and substitution. * September 2014: Florian Haftmann, TUM Lexicographic order on functions and sum/product over function bodies. * August 2014: Andreas Lochbihler, ETH Zurich Test infrastructure for executing generated code in target languages. * August 2014: Manuel Eberl, TUM Generic euclidean algorithms for GCD et al. Contributions to Isabelle2014 ----------------------------- * July 2014: Thomas Sewell, NICTA Preserve equality hypotheses in "clarify" and friends. New "hypsubst_thin" method configuration option. * Summer 2014: Florian Haftmann, TUM Consolidation and generalization of facts concerning (abelian) semigroups and monoids, particularly products (resp. sums) on finite sets. * Summer 2014: Mathias Fleury, ENS Rennes, and Albert Steckermeier, TUM Work on exotic automatic theorem provers for Sledgehammer (LEO-II, veriT, Waldmeister, etc.). * June 2014: Florian Haftmann, TUM Internal reorganisation of the local theory / named target stack. * June 2014: Sudeep Kanav, TUM, Jeremy Avigad, CMU, and Johannes Hölzl, TUM Various properties of exponentially, Erlang, and normal distributed random variables. * May 2014: Cezary Kaliszyk, University of Innsbruck, and Jasmin Blanchette, TUM SML-based engines for MaSh. * March 2014: René Thiemann Improved code generation for multisets. * February 2014: Florian Haftmann, TUM Permanent interpretation inside theory, locale and class targets with mixin definitions. * Spring 2014: Lawrence C Paulson, Cambridge Theory Complex_Basic_Analysis. Tidying up Number_Theory vs Old_Number_Theory * Winter 2013 and Spring 2014: Ondrej Kuncar, TUM Various improvements to Lifting/Transfer, integration with the BNF package. * Winter 2013 and Spring 2014: Makarius Wenzel, Université Paris-Sud / LRI Improvements of Isabelle/Scala and Isabelle/jEdit Prover IDE. * Fall 2013 and Winter 2014: Martin Desharnais, Lorenz Panny, Dmitriy Traytel, and Jasmin Blanchette, TUM Various improvements to the BNF-based (co)datatype package, including a more polished "primcorec" command, optimizations, and integration in the "HOL" session. * Winter/Spring 2014: Sascha Boehme, QAware GmbH, and Jasmin Blanchette, TUM "SMT2" module and "smt2" proof method, based on SMT-LIB 2 and Z3 4.3. * January 2014: Lars Hupel, TUM An improved, interactive simplifier trace with integration into the Isabelle/jEdit Prover IDE. * December 2013: Florian Haftmann, TUM Consolidation of abstract interpretations concerning min and max. * November 2013: Florian Haftmann, TUM Abolition of negative numeral literals in the logic. Contributions to Isabelle2013-1 ------------------------------- * September 2013: Lars Noschinski, TUM Conversion between function definitions as list of equations and case expressions in HOL. New library Simps_Case_Conv with commands case_of_simps, simps_of_case. * September 2013: Nik Sultana, University of Cambridge Improvements to HOL/TPTP parser and import facilities. * September 2013: Johannes Hölzl and Dmitriy Traytel, TUM New "coinduction" method (residing in HOL-BNF) to avoid boilerplate. * Summer 2013: Makarius Wenzel, Université Paris-Sud / LRI Improvements of Isabelle/Scala and Isabelle/jEdit Prover IDE. * Summer 2013: Manuel Eberl, TUM Generation of elimination rules in the function package. New command "fun_cases". * Summer 2013: Christian Sternagel, JAIST Improved support for ad hoc overloading of constants, including documentation and examples. * Spring and Summer 2013: Lorenz Panny, Dmitriy Traytel, and Jasmin Blanchette, TUM Various improvements to the BNF-based (co)datatype package, including "primrec_new" and "primcorec" commands and a compatibility layer. * Spring and Summer 2013: Ondrej Kuncar, TUM Various improvements of Lifting and Transfer packages. * Spring 2013: Brian Huffman, Galois Inc. Improvements of the Transfer package. * Summer 2013: Daniel Kühlwein, ICIS, Radboud University Nijmegen Jasmin Blanchette, TUM Various improvements to MaSh, including a server mode. * First half of 2013: Steffen Smolka, TUM Further improvements to Sledgehammer's Isar proof generator. * May 2013: Florian Haftmann, TUM Ephemeral interpretation in local theories. * May 2013: Lukas Bulwahn and Nicolai Schaffroth, TUM Spec_Check: A Quickcheck tool for Isabelle/ML. * April 2013: Stefan Berghofer, secunet Security Networks AG Dmitriy Traytel, TUM Makarius Wenzel, Université Paris-Sud / LRI Case translations as a separate check phase independent of the datatype package. * March 2013: Florian Haftmann, TUM Reform of "big operators" on sets. * March 2013: Florian Haftmann, TUM Algebraic locale hierarchy for orderings and (semi)lattices. * February 2013: Florian Haftmann, TUM Reworking and consolidation of code generation for target language numerals. * February 2013: Florian Haftmann, TUM Sieve of Eratosthenes. Contributions to Isabelle2013 ----------------------------- * 2012: Makarius Wenzel, Université Paris-Sud / LRI Improvements of Isabelle/Scala and Isabelle/jEdit Prover IDE. * Fall 2012: Daniel Kühlwein, ICIS, Radboud University Nijmegen Jasmin Blanchette, TUM Implemented Machine Learning for Sledgehammer (MaSh). * Fall 2012: Steffen Smolka, TUM Various improvements to Sledgehammer's Isar proof generator, including a smart type annotation algorithm and proof shrinking. * December 2012: Alessandro Coglio, Kestrel Contributions to HOL's Lattice library. * November 2012: Fabian Immler, TUM "Symbols" dockable for Isabelle/jEdit. * November 2012: Fabian Immler, TUM Proof of the Daniell-Kolmogorov theorem: the existence of the limit of projective families. * October 2012: Andreas Lochbihler, KIT Efficient construction of red-black trees from sorted associative lists. * September 2012: Florian Haftmann, TUM Lattice instances for type option. * September 2012: Christian Sternagel, JAIST Consolidated HOL/Library (theories: Prefix_Order, Sublist, and Sublist_Order) w.r.t. prefixes, suffixes, and embedding on lists. * August 2012: Dmitriy Traytel, Andrei Popescu, Jasmin Blanchette, TUM New BNF-based (co)datatype package. * August 2012: Andrei Popescu and Dmitriy Traytel, TUM Theories of ordinals and cardinals. * July 2012: Makarius Wenzel, Université Paris-Sud / LRI Advanced support for Isabelle sessions and build management, notably "isabelle build". * June 2012: Felix Kuperjans, Lukas Bulwahn, TUM and Rafal Kolanski, NICTA Simproc for rewriting set comprehensions into pointfree expressions. * May 2012: Andreas Lochbihler, KIT Theory of almost everywhere constant functions. * 2010-2012: Markus Kaiser and Lukas Bulwahn, TUM Graphview in Scala/Swing. Contributions to Isabelle2012 ----------------------------- * April 2012: Johannes Hölzl, TUM Probability: Introduced type to represent measures instead of locales. * April 2012: Johannes Hölzl, Fabian Immler, TUM Float: Moved to Dyadic rationals to represent floating point numers. * April 2012: Thomas Sewell, NICTA and 2010: Sascha Boehme, TUM Theory HOL/Word/WordBitwise: logic/circuit expansion of bitvector equalities/inequalities. * March 2012: Christian Sternagel, JAIST Consolidated theory of relation composition. * March 2012: Nik Sultana, University of Cambridge HOL/TPTP parser and import facilities. * March 2012: Cezary Kaliszyk, University of Innsbruck and Alexander Krauss, QAware GmbH Faster and more scalable Import mechanism for HOL Light proofs. * January 2012: Florian Haftmann, TUM, et al. (Re-)Introduction of the "set" type constructor. * 2012: Ondrej Kuncar, TUM New package Lifting, various improvements and refinements to the Quotient package. * 2011/2012: Jasmin Blanchette, TUM Various improvements to Sledgehammer, notably: tighter integration with SPASS, support for more provers (Alt-Ergo, iProver, iProver-Eq). * 2011/2012: Makarius Wenzel, Université Paris-Sud / LRI Various refinements of local theory infrastructure. Improvements of Isabelle/Scala layer and Isabelle/jEdit Prover IDE. Contributions to Isabelle2011-1 ------------------------------- * September 2011: Peter Gammie Theory HOL/Library/Saturated: numbers with saturated arithmetic. * August 2011: Florian Haftmann, Johannes Hölzl and Lars Noschinski, TUM Refined theory on complete lattices. * August 2011: Brian Huffman, Portland State University Miscellaneous cleanup of Complex_Main and Multivariate_Analysis. * June 2011: Brian Huffman, Portland State University Proof method "countable_datatype" for theory Library/Countable. * 2011: Jasmin Blanchette, TUM Various improvements to Sledgehammer, notably: use of sound translations, support for more provers (Waldmeister, LEO-II, Satallax). Further development of Nitpick and 'try' command. * 2011: Andreas Lochbihler, Karlsruhe Institute of Technology Theory HOL/Library/Cset_Monad allows do notation for computable sets (cset) via the generic monad ad-hoc overloading facility. * 2011: Johannes Hölzl, Armin Heller, TUM and Bogdan Grechuk, University of Edinburgh Theory HOL/Library/Extended_Reals: real numbers extended with plus and minus infinity. * 2011: Makarius Wenzel, Université Paris-Sud / LRI Various building blocks for Isabelle/Scala layer and Isabelle/jEdit Prover IDE. Contributions to Isabelle2011 ----------------------------- * January 2011: Stefan Berghofer, secunet Security Networks AG HOL-SPARK: an interactive prover back-end for SPARK. * October 2010: Bogdan Grechuk, University of Edinburgh Extended convex analysis in Multivariate Analysis. * October 2010: Dmitriy Traytel, TUM Coercive subtyping via subtype constraints. * October 2010: Alexander Krauss, TUM Command partial_function for function definitions based on complete partial orders in HOL. * September 2010: Florian Haftmann, TUM Refined concepts for evaluation, i.e., normalization of terms using different techniques. * September 2010: Florian Haftmann, TUM Code generation for Scala. * August 2010: Johannes Hoelzl, Armin Heller, and Robert Himmelmann, TUM Improved Probability theory in HOL. * July 2010: Florian Haftmann, TUM Reworking and extension of the Imperative HOL framework. * July 2010: Alexander Krauss, TUM and Christian Sternagel, University of Innsbruck Ad-hoc overloading. Generic do notation for monads. Contributions to Isabelle2009-2 ------------------------------- * 2009/2010: Stefan Berghofer, Alexander Krauss, and Andreas Schropp, TUM, Makarius Wenzel, TUM / LRI Elimination of type classes from proof terms. * April 2010: Florian Haftmann, TUM Reorganization of abstract algebra type classes. * April 2010: Florian Haftmann, TUM Code generation for data representations involving invariants; various collections avaiable in theories Fset, Dlist, RBT, Mapping and AssocList. * March 2010: Sascha Boehme, TUM Efficient SHA1 library for Poly/ML. * February 2010: Cezary Kaliszyk and Christian Urban, TUM Quotient type package for Isabelle/HOL. Contributions to Isabelle2009-1 ------------------------------- * November 2009, Brian Huffman, PSU New definitional domain package for HOLCF. * November 2009: Robert Himmelmann, TUM Derivation and Brouwer's fixpoint theorem in Multivariate Analysis. * November 2009: Stefan Berghofer and Lukas Bulwahn, TUM A tabled implementation of the reflexive transitive closure. * November 2009: Lukas Bulwahn, TUM Predicate Compiler: a compiler for inductive predicates to equational specifications. * November 2009: Sascha Boehme, TUM and Burkhart Wolff, LRI Paris HOL-Boogie: an interactive prover back-end for Boogie and VCC. * October 2009: Jasmin Blanchette, TUM Nitpick: yet another counterexample generator for Isabelle/HOL. * October 2009: Sascha Boehme, TUM Extension of SMT method: proof-reconstruction for the SMT solver Z3. * October 2009: Florian Haftmann, TUM Refinement of parts of the HOL datatype package. * October 2009: Florian Haftmann, TUM Generic term styles for term antiquotations. * September 2009: Thomas Sewell, NICTA More efficient HOL/record implementation. * September 2009: Sascha Boehme, TUM SMT method using external SMT solvers. * September 2009: Florian Haftmann, TUM Refinement of sets and lattices. * July 2009: Jeremy Avigad and Amine Chaieb New number theory. * July 2009: Philipp Meyer, TUM HOL/Library/Sum_Of_Squares: functionality to call a remote csdp prover. * July 2009: Florian Haftmann, TUM New quickcheck implementation using new code generator. * July 2009: Florian Haftmann, TUM HOL/Library/Fset: an explicit type of sets; finite sets ready to use for code generation. * June 2009: Florian Haftmann, TUM HOL/Library/Tree: search trees implementing mappings, ready to use for code generation. * March 2009: Philipp Meyer, TUM Minimization tool for results from Sledgehammer. Contributions to Isabelle2009 ----------------------------- * March 2009: Robert Himmelmann, TUM and Amine Chaieb, University of Cambridge Elementary topology in Euclidean space. * March 2009: Johannes Hoelzl, TUM Method "approximation", which proves real valued inequalities by computation. * February 2009: Filip Maric, Univ. of Belgrade A Serbian theory. * February 2009: Jasmin Christian Blanchette, TUM Misc cleanup of HOL/refute. * February 2009: Timothy Bourke, NICTA New find_consts command. * February 2009: Timothy Bourke, NICTA "solves" criterion for find_theorems and auto_solve option * December 2008: Clemens Ballarin, TUM New locale implementation. * December 2008: Armin Heller, TUM and Alexander Krauss, TUM Method "sizechange" for advanced termination proofs. * November 2008: Timothy Bourke, NICTA Performance improvement (factor 50) for find_theorems. * 2008: Florian Haftmann, TUM Various extensions and restructurings in HOL, improvements in evaluation mechanisms, new module binding.ML for name bindings. * October 2008: Fabian Immler, TUM ATP manager for Sledgehammer, based on ML threads instead of Posix processes. Additional ATP wrappers, including remote SystemOnTPTP services. * September 2008: Stefan Berghofer, TUM and Marc Bezem, Univ. Bergen Prover for coherent logic. * August 2008: Fabian Immler, TUM Vampire wrapper script for remote SystemOnTPTP service. Contributions to Isabelle2008 ----------------------------- * 2007/2008: Alexander Krauss, TUM and Florian Haftmann, TUM and Stefan Berghofer, TUM HOL library improvements. * 2007/2008: Brian Huffman, PSU HOLCF library improvements. * 2007/2008: Stefan Berghofer, TUM HOL-Nominal package improvements. * March 2008: Markus Reiter, TUM HOL/Library/RBT: red-black trees. * February 2008: Alexander Krauss, TUM and Florian Haftmann, TUM and Lukas Bulwahn, TUM and John Matthews, Galois: HOL/Library/Imperative_HOL: Haskell-style imperative data structures for HOL. * December 2007: Norbert Schirmer, Uni Saarbruecken Misc improvements of record package in HOL. * December 2007: Florian Haftmann, TUM Overloading and class instantiation target. * December 2007: Florian Haftmann, TUM New version of primrec package for local theories. * December 2007: Alexander Krauss, TUM Method "induction_scheme" in HOL. * November 2007: Peter Lammich, Uni Muenster HOL-Lattice: some more lemmas. Contributions to Isabelle2007 ----------------------------- * October 2007: Norbert Schirmer, TUM / Uni Saarbruecken State Spaces: The Locale Way (in HOL). * October 2007: Mark A. Hillebrand, DFKI Robust sub/superscripts in LaTeX document output. * August 2007: Jeremy Dawson, NICTA and Paul Graunke, Galois and Brian Huffman, PSU and Gerwin Klein, NICTA and John Matthews, Galois HOL-Word: a library for fixed-size machine words in Isabelle. * August 2007: Brian Huffman, PSU HOL/Library/Boolean_Algebra and HOL/Library/Numeral_Type. * June 2007: Amine Chaieb, TUM Semiring normalization and Groebner Bases. Support for dense linear orders. * June 2007: Joe Hurd, Oxford Metis theorem-prover. * 2007: Kong W. Susanto, Cambridge HOL: Metis prover integration. * 2007: Stefan Berghofer, TUM HOL: inductive predicates and sets. * 2007: Norbert Schirmer, TUM HOL/record: misc improvements. * 2006/2007: Alexander Krauss, TUM HOL: function package and related theories on termination. * 2006/2007: Florian Haftmann, TUM Pure: generic code generator framework. Pure: class package. HOL: theory reorganization, code generator setup. * 2006/2007: Christian Urban, TUM and Stefan Berghofer, TUM and Julien Narboux, TUM HOL/Nominal package and related tools. * November 2006: Lukas Bulwahn, TUM HOL: method "lexicographic_order" for function package. * October 2006: Stefan Hohe, TUM HOL-Algebra: ideals and quotients over rings. * August 2006: Amine Chaieb, TUM Experimental support for generic reflection and reification in HOL. * July 2006: Rafal Kolanski, NICTA Hex (0xFF) and binary (0b1011) numerals. * May 2006: Klaus Aehlig, LMU Command 'normal_form': normalization by evaluation. * May 2006: Amine Chaieb, TUM HOL-Complex: Ferrante and Rackoff Algorithm for linear real arithmetic. * February 2006: Benjamin Porter, NICTA HOL and HOL-Complex: generalised mean value theorem, continuum is not denumerable, harmonic and arithmetic series, and denumerability of rationals. * October 2005: Martin Wildmoser, TUM Sketch for Isar 'guess' element. Contributions to Isabelle2005 ----------------------------- * September 2005: Lukas Bulwahn and Bernhard Haeupler, TUM HOL-Complex: Formalization of Taylor series. * September 2005: Stephan Merz, Alwen Tiu, QSL Loria Components for SAT solver method using zChaff. * September 2005: Ning Zhang and Christian Urban, LMU Munich A Chinese theory. * September 2005: Bernhard Haeupler, TUM Method comm_ring for proving equalities in commutative rings. * July/August 2005: Jeremy Avigad, Carnegie Mellon University Various improvements of the HOL and HOL-Complex library. * July 2005: Florian Zuleger, Johannes Hoelzl, and Simon Funke, TUM Some structured proofs about completeness of real numbers. * May 2005: Rafal Kolanski and Gerwin Klein, NICTA Improved retrieval of facts from theory/proof context. * February 2005: Lucas Dixon, University of Edinburgh Improved subst method. * 2005: Brian Huffman, OGI Various improvements of HOLCF. Some improvements of the HOL-Complex library. * 2005: Claire Quigley and Jia Meng, University of Cambridge Some support for asynchronous communication with external provers (experimental). * 2005: Florian Haftmann, TUM Contributions to document 'sugar'. Various ML combinators, notably linear functional transformations. Some cleanup of ML legacy. Additional antiquotations. Improved Isabelle web site. * 2004/2005: David Aspinall, University of Edinburgh Various elements of XML and PGIP based communication with user interfaces (experimental). * 2004/2005: Gerwin Klein, NICTA Contributions to document 'sugar'. Improved Isabelle web site. Improved HTML presentation of theories. * 2004/2005: Clemens Ballarin, TUM Provers: tools for transitive relations and quasi orders. Improved version of locales, notably interpretation of locales. Improved version of HOL-Algebra. * 2004/2005: Amine Chaieb, TUM Improved version of HOL presburger method. * 2004/2005: Steven Obua, TUM Improved version of HOL/Import, support for HOL-Light. Improved version of HOL-Complex-Matrix. Pure/defs: more sophisticated checks on well-formedness of overloading. Pure/Tools: an experimental evaluator for lambda terms. * 2004/2005: Norbert Schirmer, TUM Contributions to document 'sugar'. Improved version of HOL/record. * 2004/2005: Sebastian Skalberg, TUM Improved version of HOL/Import. Some internal ML reorganizations. * 2004/2005: Tjark Weber, TUM SAT solver method using zChaff. Improved version of HOL/refute. :maxLineLen=78: diff --git a/src/HOL/Algebra/Elementary_Groups.thy b/src/HOL/Algebra/Elementary_Groups.thy --- a/src/HOL/Algebra/Elementary_Groups.thy +++ b/src/HOL/Algebra/Elementary_Groups.thy @@ -1,667 +1,590 @@ section \Elementary Group Constructions\ (* Title: HOL/Algebra/Elementary_Groups.thy Author: LC Paulson, ported from HOL Light *) theory Elementary_Groups -imports Generated_Groups Multiplicative_Group "HOL-Library.Infinite_Set" +imports Generated_Groups "HOL-Library.Infinite_Set" begin subsection\Direct sum/product lemmas\ locale group_disjoint_sum = group G + AG: subgroup A G + BG: subgroup B G for G (structure) and A B begin lemma subset_one: "A \ B \ {\} \ A \ B = {\}" by auto lemma sub_id_iff: "A \ B \ {\} \ (\x\A. \y\B. x \ y = \ \ x = \ \ y = \)" (is "?lhs = ?rhs") proof - have "?lhs = (\x\A. \y\B. x \ inv y = \ \ x = \ \ inv y = \)" proof (intro ballI iffI impI) fix x y assume "A \ B \ {\}" "x \ A" "y \ B" "x \ inv y = \" then have "y = x" using group.inv_equality group_l_invI by fastforce then show "x = \ \ inv y = \" using \A \ B \ {\}\ \x \ A\ \y \ B\ by fastforce next assume "\x\A. \y\B. x \ inv y = \ \ x = \ \ inv y = \" then show "A \ B \ {\}" by auto qed also have "\ = ?rhs" by (metis BG.mem_carrier BG.subgroup_axioms inv_inv subgroup_def) finally show ?thesis . qed lemma cancel: "A \ B \ {\} \ (\x\A. \y\B. \x'\A. \y'\B. x \ y = x' \ y' \ x = x' \ y = y')" (is "?lhs = ?rhs") proof - have "(\x\A. \y\B. x \ y = \ \ x = \ \ y = \) = ?rhs" (is "?med = _") proof (intro ballI iffI impI) fix x y x' y' assume * [rule_format]: "\x\A. \y\B. x \ y = \ \ x = \ \ y = \" and AB: "x \ A" "y \ B" "x' \ A" "y' \ B" and eq: "x \ y = x' \ y'" then have carr: "x \ carrier G" "x' \ carrier G" "y \ carrier G" "y' \ carrier G" using AG.subset BG.subset by auto then have "inv x' \ x \ (y \ inv y') = inv x' \ (x \ y) \ inv y'" by (simp add: m_assoc) also have "\ = \" using carr by (simp add: eq) (simp add: m_assoc) finally have 1: "inv x' \ x \ (y \ inv y') = \" . show "x = x' \ y = y'" using * [OF _ _ 1] AB by simp (metis carr inv_closed inv_inv local.inv_equality) next fix x y assume * [rule_format]: "\x\A. \y\B. \x'\A. \y'\B. x \ y = x' \ y' \ x = x' \ y = y'" and xy: "x \ A" "y \ B" "x \ y = \" show "x = \ \ y = \" by (rule *) (use xy in auto) qed then show ?thesis by (simp add: sub_id_iff) qed lemma commuting_imp_normal1: assumes sub: "carrier G \ A <#> B" and mult: "\x y. \x \ A; y \ B\ \ x \ y = y \ x" shows "A \ G" proof - have AB: "A \ carrier G \ B \ carrier G" by (simp add: AG.subset BG.subset) have "A #> x = x <# A" if x: "x \ carrier G" for x proof - obtain a b where xeq: "x = a \ b" and "a \ A" "b \ B" and carr: "a \ carrier G" "b \ carrier G" using x sub AB by (force simp: set_mult_def) have Ab: "A <#> {b} = {b} <#> A" using AB \a \ A\ \b \ B\ mult by (force simp: set_mult_def m_assoc subset_iff) have "A #> x = A <#> {a \ b}" by (auto simp: l_coset_eq_set_mult r_coset_eq_set_mult xeq) also have "\ = A <#> {a} <#> {b}" using AB \a \ A\ \b \ B\ by (auto simp: set_mult_def m_assoc subset_iff) also have "\ = {a} <#> A <#> {b}" by (metis AG.rcos_const AG.subgroup_axioms \a \ A\ coset_join3 is_group l_coset_eq_set_mult r_coset_eq_set_mult subgroup.mem_carrier) also have "\ = {a} <#> {b} <#> A" by (simp add: is_group carr group.set_mult_assoc AB Ab) also have "\ = {x} <#> A" by (auto simp: set_mult_def xeq) finally show "A #> x = x <# A" by (simp add: l_coset_eq_set_mult) qed then show ?thesis by (auto simp: normal_def normal_axioms_def AG.subgroup_axioms is_group) qed lemma commuting_imp_normal2: assumes"carrier G \ A <#> B" "\x y. \x \ A; y \ B\ \ x \ y = y \ x" shows "B \ G" proof (rule group_disjoint_sum.commuting_imp_normal1) show "group_disjoint_sum G B A" proof qed next show "carrier G \ B <#> A" using BG.subgroup_axioms assms commut_normal commuting_imp_normal1 by blast qed (use assms in auto) lemma (in group) normal_imp_commuting: assumes "A \ G" "B \ G" "A \ B \ {\}" "x \ A" "y \ B" shows "x \ y = y \ x" proof - interpret AG: normal A G using assms by auto interpret BG: normal B G using assms by auto interpret group_disjoint_sum G A B proof qed have * [rule_format]: "(\x\A. \y\B. \x'\A. \y'\B. x \ y = x' \ y' \ x = x' \ y = y')" using cancel assms by (auto simp: normal_def) have carr: "x \ carrier G" "y \ carrier G" using assms AG.subset BG.subset by auto then show ?thesis using * [of x _ _ y] AG.coset_eq [rule_format, of y] BG.coset_eq [rule_format, of x] by (clarsimp simp: l_coset_def r_coset_def set_eq_iff) (metis \x \ A\ \y \ B\) qed lemma normal_eq_commuting: assumes "carrier G \ A <#> B" "A \ B \ {\}" shows "A \ G \ B \ G \ (\x\A. \y\B. x \ y = y \ x)" by (metis assms commuting_imp_normal1 commuting_imp_normal2 normal_imp_commuting) lemma (in group) hom_group_mul_rev: assumes "(\(x,y). x \ y) \ hom (subgroup_generated G A \\ subgroup_generated G B) G" (is "?h \ hom ?P G") and "x \ carrier G" "y \ carrier G" "x \ A" "y \ B" shows "x \ y = y \ x" proof - interpret P: group_hom ?P G ?h by (simp add: assms DirProd_group group_hom.intro group_hom_axioms.intro is_group) have xy: "(x,y) \ carrier ?P" by (auto simp: assms carrier_subgroup_generated generate.incl) have "x \ (x \ (y \ y)) = x \ (y \ (x \ y))" using P.hom_mult [OF xy xy] by (simp add: m_assoc assms) then have "x \ (y \ y) = y \ (x \ y)" using assms by simp then show ?thesis by (simp add: assms flip: m_assoc) qed lemma hom_group_mul_eq: "(\(x,y). x \ y) \ hom (subgroup_generated G A \\ subgroup_generated G B) G \ (\x\A. \y\B. x \ y = y \ x)" (is "?lhs = ?rhs") proof assume ?lhs then show ?rhs using hom_group_mul_rev AG.subset BG.subset by blast next assume R: ?rhs have subG: "generate G (carrier G \ A) \ carrier G" for A by (simp add: generate_incl) have *: "x \ u \ (y \ v) = x \ y \ (u \ v)" if eq [rule_format]: "\x\A. \y\B. x \ y = y \ x" and gen: "x \ generate G (carrier G \ A)" "y \ generate G (carrier G \ B)" "u \ generate G (carrier G \ A)" "v \ generate G (carrier G \ B)" for x y u v proof - have "u \ y = y \ u" by (metis AG.carrier_subgroup_generated_subgroup BG.carrier_subgroup_generated_subgroup carrier_subgroup_generated eq that(3) that(4)) then have "x \ u \ y = x \ y \ u" using gen by (simp add: m_assoc subsetD [OF subG]) then show ?thesis using gen by (simp add: subsetD [OF subG] flip: m_assoc) qed show ?lhs using R by (auto simp: hom_def carrier_subgroup_generated subsetD [OF subG] *) qed lemma epi_group_mul_eq: "(\(x,y). x \ y) \ epi (subgroup_generated G A \\ subgroup_generated G B) G \ A <#> B = carrier G \ (\x\A. \y\B. x \ y = y \ x)" proof - have subGA: "generate G (carrier G \ A) \ A" by (simp add: AG.subgroup_axioms generate_subgroup_incl) have subGB: "generate G (carrier G \ B) \ B" by (simp add: BG.subgroup_axioms generate_subgroup_incl) have "(((\(x, y). x \ y) ` (generate G (carrier G \ A) \ generate G (carrier G \ B)))) = ((A <#> B))" by (auto simp: set_mult_def generate.incl pair_imageI dest: subsetD [OF subGA] subsetD [OF subGB]) then show ?thesis by (auto simp: epi_def hom_group_mul_eq carrier_subgroup_generated) qed lemma mon_group_mul_eq: "(\(x,y). x \ y) \ mon (subgroup_generated G A \\ subgroup_generated G B) G \ A \ B = {\} \ (\x\A. \y\B. x \ y = y \ x)" proof - have subGA: "generate G (carrier G \ A) \ A" by (simp add: AG.subgroup_axioms generate_subgroup_incl) have subGB: "generate G (carrier G \ B) \ B" by (simp add: BG.subgroup_axioms generate_subgroup_incl) show ?thesis apply (auto simp: mon_def hom_group_mul_eq simp flip: subset_one) apply (simp_all (no_asm_use) add: inj_on_def AG.carrier_subgroup_generated_subgroup BG.carrier_subgroup_generated_subgroup) using cancel apply blast+ done qed lemma iso_group_mul_alt: "(\(x,y). x \ y) \ iso (subgroup_generated G A \\ subgroup_generated G B) G \ A \ B = {\} \ A <#> B = carrier G \ (\x\A. \y\B. x \ y = y \ x)" by (auto simp: iso_iff_mon_epi mon_group_mul_eq epi_group_mul_eq) lemma iso_group_mul_eq: "(\(x,y). x \ y) \ iso (subgroup_generated G A \\ subgroup_generated G B) G \ A \ B = {\} \ A <#> B = carrier G \ A \ G \ B \ G" by (simp add: iso_group_mul_alt normal_eq_commuting cong: conj_cong) lemma (in group) iso_group_mul_gen: assumes "A \ G" "B \ G" shows "(\(x,y). x \ y) \ iso (subgroup_generated G A \\ subgroup_generated G B) G \ A \ B \ {\} \ A <#> B = carrier G" proof - interpret group_disjoint_sum G A B using assms by (auto simp: group_disjoint_sum_def normal_def) show ?thesis by (simp add: subset_one iso_group_mul_eq assms) qed lemma iso_group_mul: assumes "comm_group G" shows "((\(x,y). x \ y) \ iso (DirProd (subgroup_generated G A) (subgroup_generated G B)) G \ A \ B \ {\} \ A <#> B = carrier G)" proof (rule iso_group_mul_gen) interpret comm_group by (rule assms) show "A \ G" by (simp add: AG.subgroup_axioms subgroup_imp_normal) show "B \ G" by (simp add: BG.subgroup_axioms subgroup_imp_normal) qed end subsection\The one-element group on a given object\ definition singleton_group :: "'a \ 'a monoid" where "singleton_group a = \carrier = {a}, monoid.mult = (\x y. a), one = a\" lemma singleton_group [simp]: "group (singleton_group a)" unfolding singleton_group_def by (auto intro: groupI) lemma singleton_abelian_group [simp]: "comm_group (singleton_group a)" by (metis group.group_comm_groupI monoid.simps(1) singleton_group singleton_group_def) lemma carrier_singleton_group [simp]: "carrier (singleton_group a) = {a}" by (auto simp: singleton_group_def) lemma (in group) hom_into_singleton_iff [simp]: "h \ hom G (singleton_group a) \ h \ carrier G \ {a}" by (auto simp: hom_def singleton_group_def) declare group.hom_into_singleton_iff [simp] lemma (in group) id_hom_singleton: "id \ hom (singleton_group \) G" by (simp add: hom_def singleton_group_def) subsection\Similarly, trivial groups\ definition trivial_group :: "('a, 'b) monoid_scheme \ bool" where "trivial_group G \ group G \ carrier G = {one G}" lemma trivial_imp_finite_group: "trivial_group G \ finite(carrier G)" by (simp add: trivial_group_def) lemma trivial_singleton_group [simp]: "trivial_group(singleton_group a)" by (metis monoid.simps(2) partial_object.simps(1) singleton_group singleton_group_def trivial_group_def) lemma (in group) trivial_group_subset: "trivial_group G \ carrier G \ {one G}" using is_group trivial_group_def by fastforce lemma (in group) trivial_group: "trivial_group G \ (\a. carrier G = {a})" unfolding trivial_group_def using one_closed is_group by fastforce lemma (in group) trivial_group_alt: "trivial_group G \ (\a. carrier G \ {a})" by (auto simp: trivial_group) lemma (in group) trivial_group_subgroup_generated: assumes "S \ {one G}" shows "trivial_group(subgroup_generated G S)" proof - have "carrier (subgroup_generated G S) \ {\}" using generate_empty generate_one subset_singletonD assms by (fastforce simp add: carrier_subgroup_generated) then show ?thesis by (simp add: group.trivial_group_subset) qed lemma (in group) trivial_group_subgroup_generated_eq: "trivial_group(subgroup_generated G s) \ carrier G \ s \ {one G}" apply (rule iffI) apply (force simp: trivial_group_def carrier_subgroup_generated generate.incl) by (metis subgroup_generated_restrict trivial_group_subgroup_generated) lemma isomorphic_group_triviality1: assumes "G \ H" "group H" "trivial_group G" shows "trivial_group H" using assms by (auto simp: trivial_group_def is_iso_def iso_def group.is_monoid Group.group_def bij_betw_def hom_one) lemma isomorphic_group_triviality: assumes "G \ H" "group G" "group H" shows "trivial_group G \ trivial_group H" by (meson assms group.iso_sym isomorphic_group_triviality1) lemma (in group_hom) kernel_from_trivial_group: "trivial_group G \ kernel G H h = carrier G" by (auto simp: trivial_group_def kernel_def) lemma (in group_hom) image_from_trivial_group: "trivial_group G \ h ` carrier G = {one H}" by (auto simp: trivial_group_def) lemma (in group_hom) kernel_to_trivial_group: "trivial_group H \ kernel G H h = carrier G" unfolding kernel_def trivial_group_def using hom_closed by blast subsection\The additive group of integers\ definition integer_group where "integer_group = \carrier = UNIV, monoid.mult = (+), one = (0::int)\" lemma group_integer_group [simp]: "group integer_group" unfolding integer_group_def proof (rule groupI; simp) show "\x::int. \y. y + x = 0" by presburger qed lemma carrier_integer_group [simp]: "carrier integer_group = UNIV" by (auto simp: integer_group_def) lemma one_integer_group [simp]: "\\<^bsub>integer_group\<^esub> = 0" by (auto simp: integer_group_def) lemma mult_integer_group [simp]: "x \\<^bsub>integer_group\<^esub> y = x + y" by (auto simp: integer_group_def) lemma inv_integer_group [simp]: "inv\<^bsub>integer_group\<^esub> x = -x" by (rule group.inv_equality [OF group_integer_group]) (auto simp: integer_group_def) lemma abelian_integer_group: "comm_group integer_group" by (rule group.group_comm_groupI [OF group_integer_group]) (auto simp: integer_group_def) lemma group_nat_pow_integer_group [simp]: fixes n::nat and x::int shows "pow integer_group x n = int n * x" by (induction n) (auto simp: integer_group_def algebra_simps) lemma group_int_pow_integer_group [simp]: fixes n::int and x::int shows "pow integer_group x n = n * x" by (simp add: int_pow_def2) lemma (in group) hom_integer_group_pow: "x \ carrier G \ pow G x \ hom integer_group G" by (rule homI) (auto simp: int_pow_mult) subsection\Additive group of integers modulo n (n = 0 gives just the integers)\ definition integer_mod_group :: "nat \ int monoid" where "integer_mod_group n \ if n = 0 then integer_group else \carrier = {0..x y. (x+y) mod int n), one = 0\" lemma carrier_integer_mod_group: "carrier(integer_mod_group n) = (if n=0 then UNIV else {0..x y. (x + y) mod int n)" by (simp add: integer_mod_group_def integer_group_def) lemma group_integer_mod_group [simp]: "group (integer_mod_group n)" proof - have *: "\y\0. y < int n \ (y + x) mod int n = 0" if "x < int n" "0 \ x" for x proof (cases "x=0") case False with that show ?thesis by (rule_tac x="int n - x" in exI) auto qed (use that in auto) show ?thesis apply (rule groupI) apply (auto simp: integer_mod_group_def Bex_def *, presburger+) done qed lemma inv_integer_mod_group[simp]: "x \ carrier (integer_mod_group n) \ m_inv(integer_mod_group n) x = (-x) mod int n" by (rule group.inv_equality [OF group_integer_mod_group]) (auto simp: integer_mod_group_def add.commute mod_add_right_eq) lemma pow_integer_mod_group [simp]: fixes m::nat shows "pow (integer_mod_group n) x m = (int m * x) mod int n" proof (cases "n=0") case False show ?thesis by (induction m) (auto simp: add.commute mod_add_right_eq distrib_left mult.commute) qed (simp add: integer_mod_group_def) lemma int_pow_integer_mod_group: "pow (integer_mod_group n) x m = (m * x) mod int n" proof - have "inv\<^bsub>integer_mod_group n\<^esub> (- (m * x) mod int n) = m * x mod int n" by (simp add: carrier_integer_mod_group mod_minus_eq) then show ?thesis by (simp add: int_pow_def2) qed lemma abelian_integer_mod_group [simp]: "comm_group(integer_mod_group n)" by (simp add: add.commute group.group_comm_groupI) lemma integer_mod_group_0 [simp]: "0 \ carrier(integer_mod_group n)" by (simp add: integer_mod_group_def) lemma integer_mod_group_1 [simp]: "1 \ carrier(integer_mod_group n) \ (n \ 1)" by (auto simp: integer_mod_group_def) lemma trivial_integer_mod_group: "trivial_group(integer_mod_group n) \ n = 1" (is "?lhs = ?rhs") proof assume ?lhs then show ?rhs by (simp add: trivial_group_def carrier_integer_mod_group set_eq_iff split: if_split_asm) (presburger+) next assume ?rhs then show ?lhs by (force simp: trivial_group_def carrier_integer_mod_group) qed subsection\Cyclic groups\ lemma (in group) subgroup_of_powers: "x \ carrier G \ subgroup (range (\n::int. x [^] n)) G" apply (auto simp: subgroup_def image_iff simp flip: int_pow_mult int_pow_neg) apply (metis group.int_pow_diff int_pow_closed is_group r_inv) done lemma (in group) carrier_subgroup_generated_by_singleton: assumes "x \ carrier G" shows "carrier(subgroup_generated G {x}) = (range (\n::int. x [^] n))" proof show "carrier (subgroup_generated G {x}) \ range (\n::int. x [^] n)" proof (rule subgroup_generated_minimal) show "subgroup (range (\n::int. x [^] n)) G" using assms subgroup_of_powers by blast show "{x} \ range (\n::int. x [^] n)" by clarify (metis assms int_pow_1 range_eqI) qed have x: "x \ carrier (subgroup_generated G {x})" using assms subgroup_generated_subset_carrier_subset by auto show "range (\n::int. x [^] n) \ carrier (subgroup_generated G {x})" proof clarify fix n :: "int" show "x [^] n \ carrier (subgroup_generated G {x})" by (simp add: x subgroup_int_pow_closed subgroup_subgroup_generated) qed qed definition cyclic_group where "cyclic_group G \ \x \ carrier G. subgroup_generated G {x} = G" lemma (in group) cyclic_group: "cyclic_group G \ (\x \ carrier G. carrier G = range (\n::int. x [^] n))" proof - have "\x. \x \ carrier G; carrier G = range (\n::int. x [^] n)\ \ \x\carrier G. subgroup_generated G {x} = G" by (rule_tac x=x in bexI) (auto simp: generate_pow subgroup_generated_def intro!: monoid.equality) then show ?thesis unfolding cyclic_group_def using carrier_subgroup_generated_by_singleton by fastforce qed lemma cyclic_integer_group [simp]: "cyclic_group integer_group" proof - have *: "int n \ generate integer_group {1}" for n proof (induction n) case 0 then show ?case using generate.simps by force next case (Suc n) then show ?case by simp (metis generate.simps insert_subset integer_group_def monoid.simps(1) subsetI) qed have **: "i \ generate integer_group {1}" for i proof (cases i rule: int_cases) case (nonneg n) then show ?thesis by (simp add: *) next case (neg n) then have "-i \ generate integer_group {1}" by (metis "*" add.inverse_inverse) then have "- (-i) \ generate integer_group {1}" by (metis UNIV_I group.generate_m_inv_closed group_integer_group integer_group_def inv_integer_group partial_object.select_convs(1) subsetI) then show ?thesis by simp qed show ?thesis unfolding cyclic_group_def by (rule_tac x=1 in bexI) (auto simp: carrier_subgroup_generated ** intro: monoid.equality) qed lemma nontrivial_integer_group [simp]: "\ trivial_group integer_group" using integer_mod_group_def trivial_integer_mod_group by presburger lemma (in group) cyclic_imp_abelian_group: "cyclic_group G \ comm_group G" apply (auto simp: cyclic_group comm_group_def is_group intro!: monoid_comm_monoidI) apply (metis add.commute int_pow_mult rangeI) done lemma trivial_imp_cyclic_group: "trivial_group G \ cyclic_group G" by (metis cyclic_group_def group.subgroup_generated_group_carrier insertI1 trivial_group_def) lemma (in group) cyclic_group_alt: "cyclic_group G \ (\x. subgroup_generated G {x} = G)" proof safe fix x assume *: "subgroup_generated G {x} = G" show "cyclic_group G" proof (cases "x \ carrier G") case True then show ?thesis using \subgroup_generated G {x} = G\ cyclic_group_def by blast next case False then show ?thesis by (metis "*" Int_empty_right Int_insert_right_if0 carrier_subgroup_generated generate_empty trivial_group trivial_imp_cyclic_group) qed qed (auto simp: cyclic_group_def) lemma (in group) cyclic_group_generated: "cyclic_group (subgroup_generated G {x})" using group.cyclic_group_alt group_subgroup_generated subgroup_generated2 by blast lemma (in group) cyclic_group_epimorphic_image: assumes "h \ epi G H" "cyclic_group G" "group H" shows "cyclic_group H" proof - interpret h: group_hom using assms by (simp add: group_hom_def group_hom_axioms_def is_group epi_def) obtain x where "x \ carrier G" and x: "carrier G = range (\n::int. x [^] n)" and eq: "carrier H = h ` carrier G" using assms by (auto simp: cyclic_group epi_def) have "h ` carrier G = range (\n::int. h x [^]\<^bsub>H\<^esub> n)" by (metis (no_types, lifting) \x \ carrier G\ h.hom_int_pow image_cong image_image x) then show ?thesis using \x \ carrier G\ eq h.cyclic_group by blast qed lemma isomorphic_group_cyclicity: "\G \ H; group G; group H\ \ cyclic_group G \ cyclic_group H" by (meson ex_in_conv group.cyclic_group_epimorphic_image group.iso_sym is_iso_def iso_iff_mon_epi) -lemma (in group) - assumes "x \ carrier G" - shows finite_cyclic_subgroup: - "finite(carrier(subgroup_generated G {x})) \ (\n::nat. n \ 0 \ x [^] n = \)" (is "?fin \ ?nat1") - and infinite_cyclic_subgroup: - "infinite(carrier(subgroup_generated G {x})) \ (\m n::nat. x [^] m = x [^] n \ m = n)" (is "\ ?fin \ ?nateq") - and finite_cyclic_subgroup_int: - "finite(carrier(subgroup_generated G {x})) \ (\i::int. i \ 0 \ x [^] i = \)" (is "?fin \ ?int1") - and infinite_cyclic_subgroup_int: - "infinite(carrier(subgroup_generated G {x})) \ (\i j::int. x [^] i = x [^] j \ i = j)" (is "\ ?fin \ ?inteq") -proof - - have 1: "\ ?fin" if ?nateq - proof - - have "infinite (range (\n::nat. x [^] n))" - using that range_inj_infinite [of "(\n::nat. x [^] n)"] by (auto simp: inj_on_def) - moreover have "range (\n::nat. x [^] n) \ range (\i::int. x [^] i)" - apply clarify - by (metis assms group.int_pow_neg int_pow_closed int_pow_neg_int is_group local.inv_equality nat_pow_closed r_inv rangeI) - ultimately show ?thesis - using carrier_subgroup_generated_by_singleton [OF assms] finite_subset by auto - qed - have 2: "m = n" if mn: "x [^] m = x [^] n" and eq [rule_format]: "?inteq" for m n::nat - using eq [of "int m" "int n"] - by (simp add: int_pow_int mn) - have 3: ?nat1 if non: "\ ?inteq" - proof - - obtain i j::int where eq: "x [^] i = x [^] j" and "i \ j" - using non by auto - show ?thesis - proof (cases i j rule: linorder_cases) - case less - then have [simp]: "x [^] (j - i) = \" - by (simp add: eq assms int_pow_diff) - show ?thesis - using less by (rule_tac x="nat (j-i)" in exI) auto - next - case greater - then have [simp]: "x [^] (i - j) = \" - by (simp add: eq assms int_pow_diff) - then show ?thesis - using greater by (rule_tac x="nat (i-j)" in exI) auto - qed (use \i \ j\ in auto) - qed - have 4: "\i::int. (i \ 0) \ x [^] i = \" if "n \ 0" "x [^] n = \" for n::nat - apply (rule_tac x="int n" in exI) - by (simp add: int_pow_int that) - have 5: "finite (carrier (subgroup_generated G {x}))" if "i \ 0" and 1: "x [^] i = \" for i::int - proof - - obtain n::nat where n: "n > 0" "x [^] n = \" - using "1" "3" \i \ 0\ by fastforce - have "x [^] a \ ([^]) x ` {0.. {0.. ([^]) x ` {0.. ?nat1" "\ ?fin \ ?nateq" "?fin \ ?int1" "\ ?fin \ ?inteq" - using 1 2 3 4 5 by meson+ -qed - -lemma (in group) finite_cyclic_subgroup_order: - "x \ carrier G \ finite(carrier(subgroup_generated G {x})) \ ord x \ 0" - by (simp add: finite_cyclic_subgroup ord_eq_0) - -lemma (in group) infinite_cyclic_subgroup_order: - "x \ carrier G \ infinite (carrier(subgroup_generated G {x})) \ ord x = 0" - by (simp add: finite_cyclic_subgroup_order) - - end diff --git a/src/HOL/Algebra/Free_Abelian_Groups.thy b/src/HOL/Algebra/Free_Abelian_Groups.thy --- a/src/HOL/Algebra/Free_Abelian_Groups.thy +++ b/src/HOL/Algebra/Free_Abelian_Groups.thy @@ -1,755 +1,755 @@ section\Free Abelian Groups\ theory Free_Abelian_Groups imports - Product_Groups "HOL-Cardinals.Cardinal_Arithmetic" + Product_Groups FiniteProduct "HOL-Cardinals.Cardinal_Arithmetic" "HOL-Library.Countable_Set" "HOL-Library.Poly_Mapping" "HOL-Library.Equipollence" begin (*Move? But where?*) lemma eqpoll_Fpow: assumes "infinite A" shows "Fpow A \ A" unfolding eqpoll_iff_card_of_ordIso by (metis assms card_of_Fpow_infinite) lemma infinite_iff_card_of_countable: "\countable B; infinite B\ \ infinite A \ ( |B| \o |A| )" unfolding infinite_iff_countable_subset card_of_ordLeq countable_def by (force intro: card_of_ordLeqI ordLeq_transitive) lemma iso_imp_eqpoll_carrier: "G \ H \ carrier G \ carrier H" by (auto simp: is_iso_def iso_def eqpoll_def) subsection\Generalised finite product\ definition gfinprod :: "[('b, 'm) monoid_scheme, 'a \ 'b, 'a set] \ 'b" where "gfinprod G f A = (if finite {x \ A. f x \ \\<^bsub>G\<^esub>} then finprod G f {x \ A. f x \ \\<^bsub>G\<^esub>} else \\<^bsub>G\<^esub>)" context comm_monoid begin lemma gfinprod_closed [simp]: "f \ A \ carrier G \ gfinprod G f A \ carrier G" unfolding gfinprod_def by (auto simp: image_subset_iff_funcset intro: finprod_closed) lemma gfinprod_cong: "\A = B; f \ B \ carrier G; \i. i \ B =simp=> f i = g i\ \ gfinprod G f A = gfinprod G g B" unfolding gfinprod_def by (auto simp: simp_implies_def cong: conj_cong intro: finprod_cong) lemma gfinprod_eq_finprod [simp]: "\finite A; f \ A \ carrier G\ \ gfinprod G f A = finprod G f A" by (auto simp: gfinprod_def intro: finprod_mono_neutral_cong_left) lemma gfinprod_insert [simp]: assumes "finite {x \ A. f x \ \\<^bsub>G\<^esub>}" "f \ A \ carrier G" "f i \ carrier G" shows "gfinprod G f (insert i A) = (if i \ A then gfinprod G f A else f i \ gfinprod G f A)" proof - have f: "f \ {x \ A. f x \ \} \ carrier G" using assms by (auto simp: image_subset_iff_funcset) have "{x. x = i \ f x \ \ \ x \ A \ f x \ \} = (if f i = \ then {x \ A. f x \ \} else insert i {x \ A. f x \ \})" by auto then show ?thesis using assms unfolding gfinprod_def by (simp add: conj_disj_distribR insert_absorb f split: if_split_asm) qed lemma gfinprod_distrib: assumes fin: "finite {x \ A. f x \ \\<^bsub>G\<^esub>}" "finite {x \ A. g x \ \\<^bsub>G\<^esub>}" and "f \ A \ carrier G" "g \ A \ carrier G" shows "gfinprod G (\i. f i \ g i) A = gfinprod G f A \ gfinprod G g A" proof - have "finite {x \ A. f x \ g x \ \}" by (auto intro: finite_subset [OF _ finite_UnI [OF fin]]) then have "gfinprod G (\i. f i \ g i) A = gfinprod G (\i. f i \ g i) ({i \ A. f i \ \\<^bsub>G\<^esub>} \ {i \ A. g i \ \\<^bsub>G\<^esub>})" unfolding gfinprod_def using assms by (force intro: finprod_mono_neutral_cong) also have "\ = gfinprod G f A \ gfinprod G g A" proof - have "finprod G f ({i \ A. f i \ \\<^bsub>G\<^esub>} \ {i \ A. g i \ \\<^bsub>G\<^esub>}) = gfinprod G f A" "finprod G g ({i \ A. f i \ \\<^bsub>G\<^esub>} \ {i \ A. g i \ \\<^bsub>G\<^esub>}) = gfinprod G g A" using assms by (auto simp: gfinprod_def intro: finprod_mono_neutral_cong_right) moreover have "(\i. f i \ g i) \ {i \ A. f i \ \} \ {i \ A. g i \ \} \ carrier G" using assms by (force simp: image_subset_iff_funcset) ultimately show ?thesis using assms apply simp apply (subst finprod_multf, auto) done qed finally show ?thesis . qed lemma gfinprod_mono_neutral_cong_left: assumes "A \ B" and 1: "\i. i \ B - A \ h i = \" and gh: "\x. x \ A \ g x = h x" and h: "h \ B \ carrier G" shows "gfinprod G g A = gfinprod G h B" proof (cases "finite {x \ B. h x \ \}") case True then have "finite {x \ A. h x \ \}" apply (rule rev_finite_subset) using \A \ B\ by auto with True assms show ?thesis apply (simp add: gfinprod_def cong: conj_cong) apply (auto intro!: finprod_mono_neutral_cong_left) done next case False have "{x \ B. h x \ \} \ {x \ A. h x \ \}" using 1 by auto with False have "infinite {x \ A. h x \ \}" using infinite_super by blast with False assms show ?thesis by (simp add: gfinprod_def cong: conj_cong) qed lemma gfinprod_mono_neutral_cong_right: assumes "A \ B" "\i. i \ B - A \ g i = \" "\x. x \ A \ g x = h x" "g \ B \ carrier G" shows "gfinprod G g B = gfinprod G h A" using assms by (auto intro!: gfinprod_mono_neutral_cong_left [symmetric]) lemma gfinprod_mono_neutral_cong: assumes [simp]: "finite B" "finite A" and *: "\i. i \ B - A \ h i = \" "\i. i \ A - B \ g i = \" and gh: "\x. x \ A \ B \ g x = h x" and g: "g \ A \ carrier G" and h: "h \ B \ carrier G" shows "gfinprod G g A = gfinprod G h B" proof- have "gfinprod G g A = gfinprod G g (A \ B)" by (rule gfinprod_mono_neutral_cong_right) (use assms in auto) also have "\ = gfinprod G h (A \ B)" by (rule gfinprod_cong) (use assms in auto) also have "\ = gfinprod G h B" by (rule gfinprod_mono_neutral_cong_left) (use assms in auto) finally show ?thesis . qed end lemma (in comm_group) hom_group_sum: assumes hom: "\i. i \ I \ f i \ hom (A i) G" and grp: "\i. i \ I \ group (A i)" shows "(\x. gfinprod G (\i. (f i) (x i)) I) \ hom (sum_group I A) G" unfolding hom_def proof (intro CollectI conjI ballI) show "(\x. gfinprod G (\i. f i (x i)) I) \ carrier (sum_group I A) \ carrier G" using assms by (force simp: hom_def carrier_sum_group intro: gfinprod_closed simp flip: image_subset_iff_funcset) next fix x y assume x: "x \ carrier (sum_group I A)" and y: "y \ carrier (sum_group I A)" then have finx: "finite {i \ I. x i \ \\<^bsub>A i\<^esub>}" and finy: "finite {i \ I. y i \ \\<^bsub>A i\<^esub>}" using assms by (auto simp: carrier_sum_group) have finfx: "finite {i \ I. f i (x i) \ \}" using assms by (auto simp: is_group hom_one [OF hom] intro: finite_subset [OF _ finx]) have finfy: "finite {i \ I. f i (y i) \ \}" using assms by (auto simp: is_group hom_one [OF hom] intro: finite_subset [OF _ finy]) have carr: "f i (x i) \ carrier G" "f i (y i) \ carrier G" if "i \ I" for i using hom_carrier [OF hom] that x y assms by (fastforce simp add: carrier_sum_group)+ have lam: "(\i. f i ( x i \\<^bsub>A i\<^esub> y i)) \ I \ carrier G" using x y assms by (auto simp: hom_def carrier_sum_group PiE_def Pi_def) have lam': "(\i. f i (if i \ I then x i \\<^bsub>A i\<^esub> y i else undefined)) \ I \ carrier G" by (simp add: lam Pi_cong) with lam x y assms show "gfinprod G (\i. f i ((x \\<^bsub>sum_group I A\<^esub> y) i)) I = gfinprod G (\i. f i (x i)) I \ gfinprod G (\i. f i (y i)) I" by (simp add: carrier_sum_group PiE_def Pi_def hom_mult [OF hom] gfinprod_distrib finfx finfy carr cong: gfinprod_cong) qed subsection\Free Abelian groups on a set, using the "frag" type constructor. \ definition free_Abelian_group :: "'a set \ ('a \\<^sub>0 int) monoid" where "free_Abelian_group S = \carrier = {c. Poly_Mapping.keys c \ S}, monoid.mult = (+), one = 0\" lemma group_free_Abelian_group [simp]: "group (free_Abelian_group S)" proof - have "\x. Poly_Mapping.keys x \ S \ x \ Units (free_Abelian_group S)" unfolding free_Abelian_group_def Units_def by clarsimp (metis eq_neg_iff_add_eq_0 neg_eq_iff_add_eq_0 keys_minus) then show ?thesis unfolding free_Abelian_group_def by unfold_locales (auto simp: dest: subsetD [OF keys_add]) qed lemma carrier_free_Abelian_group_iff [simp]: shows "x \ carrier (free_Abelian_group S) \ Poly_Mapping.keys x \ S" by (auto simp: free_Abelian_group_def) lemma one_free_Abelian_group [simp]: "\\<^bsub>free_Abelian_group S\<^esub> = 0" by (auto simp: free_Abelian_group_def) lemma mult_free_Abelian_group [simp]: "x \\<^bsub>free_Abelian_group S\<^esub> y = x + y" by (auto simp: free_Abelian_group_def) lemma inv_free_Abelian_group [simp]: "Poly_Mapping.keys x \ S \ inv\<^bsub>free_Abelian_group S\<^esub> x = -x" by (rule group.inv_equality [OF group_free_Abelian_group]) auto lemma abelian_free_Abelian_group: "comm_group(free_Abelian_group S)" apply (rule group.group_comm_groupI [OF group_free_Abelian_group]) by (simp add: free_Abelian_group_def) lemma pow_free_Abelian_group [simp]: fixes n::nat shows "Group.pow (free_Abelian_group S) x n = frag_cmul (int n) x" by (induction n) (auto simp: nat_pow_def free_Abelian_group_def frag_cmul_distrib) lemma int_pow_free_Abelian_group [simp]: fixes n::int assumes "Poly_Mapping.keys x \ S" shows "Group.pow (free_Abelian_group S) x n = frag_cmul n x" proof (induction n) case (nonneg n) then show ?case by (simp add: int_pow_int) next case (neg n) have "x [^]\<^bsub>free_Abelian_group S\<^esub> - int (Suc n) = inv\<^bsub>free_Abelian_group S\<^esub> (x [^]\<^bsub>free_Abelian_group S\<^esub> int (Suc n))" by (rule group.int_pow_neg [OF group_free_Abelian_group]) (use assms in \simp add: free_Abelian_group_def\) also have "\ = frag_cmul (- int (Suc n)) x" by (metis assms inv_free_Abelian_group pow_free_Abelian_group int_pow_int minus_frag_cmul order_trans keys_cmul) finally show ?case . qed lemma frag_of_in_free_Abelian_group [simp]: "frag_of x \ carrier(free_Abelian_group S) \ x \ S" by simp lemma free_Abelian_group_induct: assumes major: "Poly_Mapping.keys x \ S" and minor: "P(0)" "\x y. \Poly_Mapping.keys x \ S; Poly_Mapping.keys y \ S; P x; P y\ \ P(x-y)" "\a. a \ S \ P(frag_of a)" shows "P x" proof - have "Poly_Mapping.keys x \ S \ P x" using major proof (induction x rule: frag_induction) case (diff a b) then show ?case by (meson Un_least minor(2) order.trans keys_diff) qed (auto intro: minor) then show ?thesis .. qed lemma sum_closed_free_Abelian_group: "(\i. i \ I \ x i \ carrier (free_Abelian_group S)) \ sum x I \ carrier (free_Abelian_group S)" apply (induction I rule: infinite_finite_induct, auto) by (metis (no_types, hide_lams) UnE subsetCE keys_add) lemma (in comm_group) free_Abelian_group_universal: fixes f :: "'c \ 'a" assumes "f ` S \ carrier G" obtains h where "h \ hom (free_Abelian_group S) G" "\x. x \ S \ h(frag_of x) = f x" proof have fin: "Poly_Mapping.keys u \ S \ finite {x \ S. f x [^] poly_mapping.lookup u x \ \}" for u :: "'c \\<^sub>0 int" apply (rule finite_subset [OF _ finite_keys [of u]]) unfolding keys.rep_eq by force define h :: "('c \\<^sub>0 int) \ 'a" where "h \ \x. gfinprod G (\a. f a [^] poly_mapping.lookup x a) S" show "h \ hom (free_Abelian_group S) G" proof (rule homI) fix x y assume xy: "x \ carrier (free_Abelian_group S)" "y \ carrier (free_Abelian_group S)" then show "h (x \\<^bsub>free_Abelian_group S\<^esub> y) = h x \ h y" using assms unfolding h_def free_Abelian_group_def by (simp add: fin gfinprod_distrib image_subset_iff Poly_Mapping.lookup_add int_pow_mult cong: gfinprod_cong) qed (use assms in \force simp: free_Abelian_group_def h_def intro: gfinprod_closed\) show "h(frag_of x) = f x" if "x \ S" for x proof - have fin: "(\a. f x [^] (1::int)) \ {x} \ carrier G" "f x [^] (1::int) \ carrier G" using assms that by force+ show ?thesis by (cases " f x [^] (1::int) = \") (use assms that in \auto simp: h_def gfinprod_def finprod_singleton\) qed qed lemma eqpoll_free_Abelian_group_infinite: assumes "infinite A" shows "carrier(free_Abelian_group A) \ A" proof (rule lepoll_antisym) have "carrier (free_Abelian_group A) \ {f::'a\int. f ` A \ UNIV \ {x. f x \ 0} \ A \ finite {x. f x \ 0}}" unfolding lepoll_def by (rule_tac x="Poly_Mapping.lookup" in exI) (auto simp: poly_mapping_eqI lookup_not_eq_zero_eq_in_keys inj_onI) also have "\ \ Fpow (A \ (UNIV::int set))" by (rule lepoll_restricted_funspace) also have "\ \ A \ (UNIV::int set)" proof (rule eqpoll_Fpow) show "infinite (A \ (UNIV::int set))" using assms finite_cartesian_productD1 by fastforce qed also have "\ \ A" unfolding eqpoll_iff_card_of_ordIso proof - have "|A \ (UNIV::int set)| <=o |A|" by (simp add: assms card_of_Times_ordLeq_infinite flip: infinite_iff_card_of_countable) moreover have "|A| \o |A \ (UNIV::int set)|" by simp ultimately have "|A| *c |(UNIV::int set)| =o |A|" by (simp add: cprod_def ordIso_iff_ordLeq) then show "|A \ (UNIV::int set)| =o |A|" by (metis Times_cprod ordIso_transitive) qed finally show "carrier (free_Abelian_group A) \ A" . have "inj_on frag_of A" by (simp add: frag_of_eq inj_on_def) moreover have "frag_of ` A \ carrier (free_Abelian_group A)" by (simp add: image_subsetI) ultimately show "A \ carrier (free_Abelian_group A)" by (force simp: lepoll_def) qed proposition (in comm_group) eqpoll_homomorphisms_from_free_Abelian_group: "{f. f \ extensional (carrier(free_Abelian_group S)) \ f \ hom (free_Abelian_group S) G} \ (S \\<^sub>E carrier G)" (is "?lhs \ ?rhs") unfolding eqpoll_def bij_betw_def proof (intro exI conjI) let ?f = "\f. restrict (f \ frag_of) S" show "inj_on ?f ?lhs" proof (clarsimp simp: inj_on_def) fix g h assume g: "g \ extensional (carrier (free_Abelian_group S))" "g \ hom (free_Abelian_group S) G" and h: "h \ extensional (carrier (free_Abelian_group S))" "h \ hom (free_Abelian_group S) G" and eq: "restrict (g \ frag_of) S = restrict (h \ frag_of) S" have 0: "0 \ carrier (free_Abelian_group S)" by simp interpret hom_g: group_hom "free_Abelian_group S" G g using g by (auto simp: group_hom_def group_hom_axioms_def is_group) interpret hom_h: group_hom "free_Abelian_group S" G h using h by (auto simp: group_hom_def group_hom_axioms_def is_group) have "Poly_Mapping.keys c \ S \ Poly_Mapping.keys c \ S \ g c = h c" for c proof (induction c rule: frag_induction) case zero show ?case using hom_g.hom_one hom_h.hom_one by auto next case (one x) then show ?case using eq by (simp add: fun_eq_iff) (metis comp_def) next case (diff a b) then show ?case using hom_g.hom_mult hom_h.hom_mult hom_g.hom_inv hom_h.hom_inv apply (auto simp: dest: subsetD [OF keys_diff]) by (metis keys_minus uminus_add_conv_diff) qed then show "g = h" by (meson g h carrier_free_Abelian_group_iff extensionalityI) qed have "f \ (\f. restrict (f \ frag_of) S) ` {f \ extensional (carrier (free_Abelian_group S)). f \ hom (free_Abelian_group S) G}" if f: "f \ S \\<^sub>E carrier G" for f :: "'c \ 'a" proof - obtain h where h: "h \ hom (free_Abelian_group S) G" "\x. x \ S \ h(frag_of x) = f x" proof (rule free_Abelian_group_universal) show "f ` S \ carrier G" using f by blast qed auto let ?h = "restrict h (carrier (free_Abelian_group S))" show ?thesis proof show "f = restrict (?h \ frag_of) S" using f by (force simp: h) show "?h \ {f \ extensional (carrier (free_Abelian_group S)). f \ hom (free_Abelian_group S) G}" using h by (auto simp: hom_def dest!: subsetD [OF keys_add]) qed qed then show "?f ` ?lhs = S \\<^sub>E carrier G" by (auto simp: hom_def Ball_def Pi_def) qed lemma hom_frag_minus: assumes "h \ hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \ S" shows "h (-a) = - (h a)" proof - have "Poly_Mapping.keys (h a) \ T" by (meson assms carrier_free_Abelian_group_iff hom_in_carrier) then show ?thesis by (metis (no_types) assms carrier_free_Abelian_group_iff group_free_Abelian_group group_hom.hom_inv group_hom_axioms_def group_hom_def inv_free_Abelian_group) qed lemma hom_frag_add: assumes "h \ hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \ S" "Poly_Mapping.keys b \ S" shows "h (a+b) = h a + h b" proof - have "Poly_Mapping.keys (h a) \ T" by (meson assms carrier_free_Abelian_group_iff hom_in_carrier) moreover have "Poly_Mapping.keys (h b) \ T" by (meson assms carrier_free_Abelian_group_iff hom_in_carrier) ultimately show ?thesis using assms hom_mult by fastforce qed lemma hom_frag_diff: assumes "h \ hom (free_Abelian_group S) (free_Abelian_group T)" "Poly_Mapping.keys a \ S" "Poly_Mapping.keys b \ S" shows "h (a-b) = h a - h b" by (metis (no_types, lifting) assms diff_conv_add_uminus hom_frag_add hom_frag_minus keys_minus) proposition isomorphic_free_Abelian_groups: "free_Abelian_group S \ free_Abelian_group T \ S \ T" (is "(?FS \ ?FT) = ?rhs") proof interpret S: group "?FS" by simp interpret T: group "?FT" by simp interpret G2: comm_group "integer_mod_group 2" by (rule abelian_integer_mod_group) let ?Two = "{0..<2::int}" have [simp]: "\ ?Two \ {a}" for a by (simp add: subset_iff) presburger assume L: "?FS \ ?FT" let ?HS = "{h \ extensional (carrier ?FS). h \ hom ?FS (integer_mod_group 2)}" let ?HT = "{h \ extensional (carrier ?FT). h \ hom ?FT (integer_mod_group 2)}" have "S \\<^sub>E ?Two \ ?HS" apply (rule eqpoll_sym) using G2.eqpoll_homomorphisms_from_free_Abelian_group by (simp add: carrier_integer_mod_group) also have "\ \ ?HT" proof - obtain f g where "group_isomorphisms ?FS ?FT f g" using L S.iso_iff_group_isomorphisms by (force simp: is_iso_def) then have f: "f \ hom ?FS ?FT" and g: "g \ hom ?FT ?FS" and gf: "\x \ carrier ?FS. g(f x) = x" and fg: "\y \ carrier ?FT. f(g y) = y" by (auto simp: group_isomorphisms_def) let ?f = "\h. restrict (h \ g) (carrier ?FT)" let ?g = "\h. restrict (h \ f) (carrier ?FS)" show ?thesis proof (rule lepoll_antisym) show "?HS \ ?HT" unfolding lepoll_def proof (intro exI conjI) show "inj_on ?f ?HS" apply (rule inj_on_inverseI [where g = ?g]) using hom_in_carrier [OF f] by (auto simp: gf fun_eq_iff carrier_integer_mod_group Ball_def Pi_def extensional_def) show "?f ` ?HS \ ?HT" proof clarsimp fix h assume h: "h \ hom ?FS (integer_mod_group 2)" have "h \ g \ hom ?FT (integer_mod_group 2)" by (rule hom_compose [OF g h]) moreover have "restrict (h \ g) (carrier ?FT) x = (h \ g) x" if "x \ carrier ?FT" for x using g that by (simp add: hom_def) ultimately show "restrict (h \ g) (carrier ?FT) \ hom ?FT (integer_mod_group 2)" using T.hom_restrict by fastforce qed qed next show "?HT \ ?HS" unfolding lepoll_def proof (intro exI conjI) show "inj_on ?g ?HT" apply (rule inj_on_inverseI [where g = ?f]) using hom_in_carrier [OF g] by (auto simp: fg fun_eq_iff carrier_integer_mod_group Ball_def Pi_def extensional_def) show "?g ` ?HT \ ?HS" proof clarsimp fix k assume k: "k \ hom ?FT (integer_mod_group 2)" have "k \ f \ hom ?FS (integer_mod_group 2)" by (rule hom_compose [OF f k]) moreover have "restrict (k \ f) (carrier ?FS) x = (k \ f) x" if "x \ carrier ?FS" for x using f that by (simp add: hom_def) ultimately show "restrict (k \ f) (carrier ?FS) \ hom ?FS (integer_mod_group 2)" using S.hom_restrict by fastforce qed qed qed qed also have "\ \ T \\<^sub>E ?Two" using G2.eqpoll_homomorphisms_from_free_Abelian_group by (simp add: carrier_integer_mod_group) finally have *: "S \\<^sub>E ?Two \ T \\<^sub>E ?Two" . then have "finite (S \\<^sub>E ?Two) \ finite (T \\<^sub>E ?Two)" by (rule eqpoll_finite_iff) then have "finite S \ finite T" by (auto simp: finite_funcset_iff) then consider "finite S" "finite T" | "~ finite S" "~ finite T" by blast then show ?rhs proof cases case 1 with * have "2 ^ card S = (2::nat) ^ card T" by (simp add: card_PiE finite_PiE eqpoll_iff_card) then have "card S = card T" by auto then show ?thesis using eqpoll_iff_card 1 by blast next case 2 have "carrier (free_Abelian_group S) \ carrier (free_Abelian_group T)" using L by (simp add: iso_imp_eqpoll_carrier) then show ?thesis using 2 eqpoll_free_Abelian_group_infinite eqpoll_sym eqpoll_trans by metis qed next assume ?rhs then obtain f g where f: "\x. x \ S \ f x \ T \ g(f x) = x" and g: "\y. y \ T \ g y \ S \ f(g y) = y" using eqpoll_iff_bijections by metis interpret S: comm_group "?FS" by (simp add: abelian_free_Abelian_group) interpret T: comm_group "?FT" by (simp add: abelian_free_Abelian_group) have "(frag_of \ f) ` S \ carrier (free_Abelian_group T)" using f by auto then obtain h where h: "h \ hom (free_Abelian_group S) (free_Abelian_group T)" and h_frag: "\x. x \ S \ h (frag_of x) = (frag_of \ f) x" using T.free_Abelian_group_universal [of "frag_of \ f" S] by blast interpret hhom: group_hom "free_Abelian_group S" "free_Abelian_group T" h by (simp add: h group_hom_axioms_def group_hom_def) have "(frag_of \ g) ` T \ carrier (free_Abelian_group S)" using g by auto then obtain k where k: "k \ hom (free_Abelian_group T) (free_Abelian_group S)" and k_frag: "\x. x \ T \ k (frag_of x) = (frag_of \ g) x" using S.free_Abelian_group_universal [of "frag_of \ g" T] by blast interpret khom: group_hom "free_Abelian_group T" "free_Abelian_group S" k by (simp add: k group_hom_axioms_def group_hom_def) have kh: "Poly_Mapping.keys x \ S \ Poly_Mapping.keys x \ S \ k (h x) = x" for x proof (induction rule: frag_induction) case zero then show ?case apply auto by (metis group_free_Abelian_group h hom_one k one_free_Abelian_group) next case (one x) then show ?case by (auto simp: h_frag k_frag f) next case (diff a b) with keys_diff have "Poly_Mapping.keys (a - b) \ S" by (metis Un_least order_trans) with diff hhom.hom_closed show ?case by (simp add: hom_frag_diff [OF h] hom_frag_diff [OF k]) qed have hk: "Poly_Mapping.keys y \ T \ Poly_Mapping.keys y \ T \ h (k y) = y" for y proof (induction rule: frag_induction) case zero then show ?case apply auto by (metis group_free_Abelian_group h hom_one k one_free_Abelian_group) next case (one y) then show ?case by (auto simp: h_frag k_frag g) next case (diff a b) with keys_diff have "Poly_Mapping.keys (a - b) \ T" by (metis Un_least order_trans) with diff khom.hom_closed show ?case by (simp add: hom_frag_diff [OF h] hom_frag_diff [OF k]) qed have "h \ iso ?FS ?FT" unfolding iso_def bij_betw_iff_bijections mem_Collect_eq proof (intro conjI exI ballI h) fix x assume x: "x \ carrier (free_Abelian_group S)" show "h x \ carrier (free_Abelian_group T)" by (meson x h hom_in_carrier) show "k (h x) = x" using x by (simp add: kh) next fix y assume y: "y \ carrier (free_Abelian_group T)" show "k y \ carrier (free_Abelian_group S)" by (meson y k hom_in_carrier) show "h (k y) = y" using y by (simp add: hk) qed then show "?FS \ ?FT" by (auto simp: is_iso_def) qed lemma isomorphic_group_integer_free_Abelian_group_singleton: "integer_group \ free_Abelian_group {x}" proof - have "(\n. frag_cmul n (frag_of x)) \ iso integer_group (free_Abelian_group {x})" proof (rule isoI [OF homI]) show "bij_betw (\n. frag_cmul n (frag_of x)) (carrier integer_group) (carrier (free_Abelian_group {x}))" apply (rule bij_betwI [where g = "\y. Poly_Mapping.lookup y x"]) by (auto simp: integer_group_def in_keys_iff intro!: poly_mapping_eqI) qed (auto simp: frag_cmul_distrib) then show ?thesis unfolding is_iso_def by blast qed lemma group_hom_free_Abelian_groups_id: "id \ hom (free_Abelian_group S) (free_Abelian_group T) \ S \ T" proof - have "x \ T" if ST: "\c:: 'a \\<^sub>0 int. Poly_Mapping.keys c \ S \ Poly_Mapping.keys c \ T" and "x \ S" for x using ST [of "frag_of x"] \x \ S\ by simp then show ?thesis by (auto simp: hom_def free_Abelian_group_def Pi_def) qed proposition iso_free_Abelian_group_sum: assumes "pairwise (\i j. disjnt (S i) (S j)) I" shows "(\f. sum' f I) \ iso (sum_group I (\i. free_Abelian_group(S i))) (free_Abelian_group (\(S ` I)))" (is "?h \ iso ?G ?H") proof (rule isoI) show hom: "?h \ hom ?G ?H" proof (rule homI) show "?h c \ carrier ?H" if "c \ carrier ?G" for c using that apply (simp add: sum.G_def carrier_sum_group) apply (rule order_trans [OF keys_sum]) apply (auto simp: free_Abelian_group_def) done show "?h (x \\<^bsub>?G\<^esub> y) = ?h x \\<^bsub>?H\<^esub> ?h y" if "x \ carrier ?G" "y \ carrier ?G" for x y using that by (simp add: sum.finite_Collect_op carrier_sum_group sum.distrib') qed interpret GH: group_hom "?G" "?H" "?h" using hom by (simp add: group_hom_def group_hom_axioms_def) show "bij_betw ?h (carrier ?G) (carrier ?H)" unfolding bij_betw_def proof (intro conjI subset_antisym) show "?h ` carrier ?G \ carrier ?H" apply (clarsimp simp: sum.G_def carrier_sum_group simp del: carrier_free_Abelian_group_iff) by (force simp: PiE_def Pi_iff intro!: sum_closed_free_Abelian_group) have *: "poly_mapping.lookup (Abs_poly_mapping (\j. if j \ S i then poly_mapping.lookup x j else 0)) k = (if k \ S i then poly_mapping.lookup x k else 0)" if "i \ I" for i k and x :: "'b \\<^sub>0 int" using that by (auto simp: conj_commute cong: conj_cong) have eq: "Abs_poly_mapping (\j. if j \ S i then poly_mapping.lookup x j else 0) = 0 \ (\c \ S i. poly_mapping.lookup x c = 0)" if "i \ I" for i and x :: "'b \\<^sub>0 int" apply (auto simp: poly_mapping_eq_iff fun_eq_iff) apply (simp add: * Abs_poly_mapping_inverse conj_commute cong: conj_cong) apply (force dest!: spec split: if_split_asm) done have "x \ ?h ` {x \ \\<^sub>E i\I. {c. Poly_Mapping.keys c \ S i}. finite {i \ I. x i \ 0}}" if x: "Poly_Mapping.keys x \ \ (S ` I)" for x :: "'b \\<^sub>0 int" proof - let ?f = "(\i c. if c \ S i then Poly_Mapping.lookup x c else 0)" define J where "J \ {i \ I. \c\S i. c \ Poly_Mapping.keys x}" have "J \ (\c. THE i. i \ I \ c \ S i) ` Poly_Mapping.keys x" proof (clarsimp simp: J_def) show "i \ (\c. THE i. i \ I \ c \ S i) ` Poly_Mapping.keys x" if "i \ I" "c \ S i" "c \ Poly_Mapping.keys x" for i c proof show "i = (THE i. i \ I \ c \ S i)" using assms that by (auto simp: pairwise_def disjnt_def intro: the_equality [symmetric]) qed (simp add: that) qed then have fin: "finite J" using finite_subset finite_keys by blast have [simp]: "Poly_Mapping.keys (Abs_poly_mapping (?f i)) = {k. ?f i k \ 0}" if "i \ I" for i by (simp add: eq_onp_def keys.abs_eq conj_commute cong: conj_cong) have [simp]: "Poly_Mapping.lookup (Abs_poly_mapping (?f i)) c = ?f i c" if "i \ I" for i c by (auto simp: Abs_poly_mapping_inverse conj_commute cong: conj_cong) show ?thesis proof have "poly_mapping.lookup x c = poly_mapping.lookup (?h (\i\I. Abs_poly_mapping (?f i))) c" for c proof (cases "c \ Poly_Mapping.keys x") case True then obtain i where "i \ I" "c \ S i" "?f i c \ 0" using x by (auto simp: in_keys_iff) then have 1: "poly_mapping.lookup (sum' (\j. Abs_poly_mapping (?f j)) (I - {i})) c = 0" using assms apply (simp add: sum.G_def Poly_Mapping.lookup_sum pairwise_def disjnt_def) apply (force simp: eq split: if_split_asm intro!: comm_monoid_add_class.sum.neutral) done have 2: "poly_mapping.lookup x c = poly_mapping.lookup (Abs_poly_mapping (?f i)) c" by (auto simp: \c \ S i\ Abs_poly_mapping_inverse conj_commute cong: conj_cong) have "finite {i \ I. Abs_poly_mapping (?f i) \ 0}" by (rule finite_subset [OF _ fin]) (use \i \ I\ J_def eq in \auto simp: in_keys_iff\) with \i \ I\ have "?h (\j\I. Abs_poly_mapping (?f j)) = Abs_poly_mapping (?f i) + sum' (\j. Abs_poly_mapping (?f j)) (I - {i})" by (simp add: sum_diff1') then show ?thesis by (simp add: 1 2 Poly_Mapping.lookup_add) next case False then have "poly_mapping.lookup x c = 0" using keys.rep_eq by force then show ?thesis unfolding sum.G_def by (simp add: lookup_sum * comm_monoid_add_class.sum.neutral) qed then show "x = ?h (\i\I. Abs_poly_mapping (?f i))" by (rule poly_mapping_eqI) have "(\i. Abs_poly_mapping (?f i)) \ (\ i\I. {c. Poly_Mapping.keys c \ S i})" by (auto simp: PiE_def Pi_def in_keys_iff) then show "(\i\I. Abs_poly_mapping (?f i)) \ {x \ \\<^sub>E i\I. {c. Poly_Mapping.keys c \ S i}. finite {i \ I. x i \ 0}}" using fin unfolding J_def by (simp add: eq in_keys_iff cong: conj_cong) qed qed then show "carrier ?H \ ?h ` carrier ?G" by (simp add: carrier_sum_group) (auto simp: free_Abelian_group_def) show "inj_on ?h (carrier (sum_group I (\i. free_Abelian_group (S i))))" unfolding GH.inj_on_one_iff proof clarify fix x assume "x \ carrier ?G" "?h x = \\<^bsub>?H\<^esub>" then have eq0: "sum' x I = 0" and xs: "\i. i \ I \ Poly_Mapping.keys (x i) \ S i" and xext: "x \ extensional I" and fin: "finite {i \ I. x i \ 0}" by (simp_all add: carrier_sum_group PiE_def Pi_def) have "x i = 0" if "i \ I" for i proof - have "sum' x (insert i (I - {i})) = 0" using eq0 that by (simp add: insert_absorb) moreover have "Poly_Mapping.keys (sum' x (I - {i})) = {}" proof - have "x i = - sum' x (I - {i})" by (metis (mono_tags, lifting) diff_zero eq0 fin sum_diff1' minus_diff_eq that) then have "Poly_Mapping.keys (x i) = Poly_Mapping.keys (sum' x (I - {i}))" by simp then have "Poly_Mapping.keys (sum' x (I - {i})) \ S i" using that xs by metis moreover have "Poly_Mapping.keys (sum' x (I - {i})) \ (\j \ I - {i}. S j)" proof - have "Poly_Mapping.keys (sum' x (I - {i})) \ (\i\{j \ I. j \ i \ x j \ 0}. Poly_Mapping.keys (x i))" using keys_sum [of x "{j \ I. j \ i \ x j \ 0}"] by (simp add: sum.G_def) also have "\ \ \ (S ` (I - {i}))" using xs by force finally show ?thesis . qed moreover have "A = {}" if "A \ S i" "A \ \ (S ` (I - {i}))" for A using assms that \i \ I\ by (force simp: pairwise_def disjnt_def image_def subset_iff) ultimately show ?thesis by metis qed then have [simp]: "sum' x (I - {i}) = 0" by (auto simp: sum.G_def) have "sum' x (insert i (I - {i})) = x i" by (subst sum.insert' [OF finite_subset [OF _ fin]]) auto ultimately show ?thesis by metis qed with xext [unfolded extensional_def] show "x = \\<^bsub>sum_group I (\i. free_Abelian_group (S i))\<^esub>" by (force simp: free_Abelian_group_def) qed qed qed lemma isomorphic_free_Abelian_group_Union: "pairwise disjnt I \ free_Abelian_group(\ I) \ sum_group I free_Abelian_group" using iso_free_Abelian_group_sum [of "\X. X" I] by (metis SUP_identity_eq empty_iff group.iso_sym group_free_Abelian_group is_iso_def sum_group) lemma isomorphic_sum_integer_group: "sum_group I (\i. integer_group) \ free_Abelian_group I" proof - have "sum_group I (\i. integer_group) \ sum_group I (\i. free_Abelian_group {i})" by (rule iso_sum_groupI) (auto simp: isomorphic_group_integer_free_Abelian_group_singleton) also have "\ \ free_Abelian_group I" using iso_free_Abelian_group_sum [of "\x. {x}" I] by (auto simp: is_iso_def) finally show ?thesis . qed end diff --git a/src/HOL/Algebra/Multiplicative_Group.thy b/src/HOL/Algebra/Multiplicative_Group.thy --- a/src/HOL/Algebra/Multiplicative_Group.thy +++ b/src/HOL/Algebra/Multiplicative_Group.thy @@ -1,910 +1,1061 @@ (* Title: HOL/Algebra/Multiplicative_Group.thy Author: Simon Wimmer Author: Lars Noschinski *) theory Multiplicative_Group imports Complex_Main Group Coset UnivPoly Generated_Groups + Elementary_Groups begin section \Simplification Rules for Polynomials\ text_raw \\label{sec:simp-rules}\ lemma (in ring_hom_cring) hom_sub[simp]: assumes "x \ carrier R" "y \ carrier R" shows "h (x \ y) = h x \\<^bsub>S\<^esub> h y" using assms by (simp add: R.minus_eq S.minus_eq) context UP_ring begin lemma deg_nzero_nzero: assumes deg_p_nzero: "deg R p \ 0" shows "p \ \\<^bsub>P\<^esub>" using deg_zero deg_p_nzero by auto lemma deg_add_eq: assumes c: "p \ carrier P" "q \ carrier P" assumes "deg R q \ deg R p" shows "deg R (p \\<^bsub>P\<^esub> q) = max (deg R p) (deg R q)" proof - let ?m = "max (deg R p) (deg R q)" from assms have "coeff P p ?m = \ \ coeff P q ?m \ \" by (metis deg_belowI lcoeff_nonzero[OF deg_nzero_nzero] linear max.absorb_iff2 max.absorb1) then have "coeff P (p \\<^bsub>P\<^esub> q) ?m \ \" using assms by auto then have "deg R (p \\<^bsub>P\<^esub> q) \ ?m" using assms by (blast intro: deg_belowI) with deg_add[OF c] show ?thesis by arith qed lemma deg_minus_eq: assumes "p \ carrier P" "q \ carrier P" "deg R q \ deg R p" shows "deg R (p \\<^bsub>P\<^esub> q) = max (deg R p) (deg R q)" using assms by (simp add: deg_add_eq a_minus_def) end context UP_cring begin lemma evalRR_add: assumes "p \ carrier P" "q \ carrier P" assumes x: "x \ carrier R" shows "eval R R id x (p \\<^bsub>P\<^esub> q) = eval R R id x p \ eval R R id x q" proof - interpret UP_pre_univ_prop R R id by unfold_locales simp interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x]) show ?thesis using assms by simp qed lemma evalRR_sub: assumes "p \ carrier P" "q \ carrier P" assumes x: "x \ carrier R" shows "eval R R id x (p \\<^bsub>P\<^esub> q) = eval R R id x p \ eval R R id x q" proof - interpret UP_pre_univ_prop R R id by unfold_locales simp interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x]) show ?thesis using assms by simp qed lemma evalRR_mult: assumes "p \ carrier P" "q \ carrier P" assumes x: "x \ carrier R" shows "eval R R id x (p \\<^bsub>P\<^esub> q) = eval R R id x p \ eval R R id x q" proof - interpret UP_pre_univ_prop R R id by unfold_locales simp interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x]) show ?thesis using assms by simp qed lemma evalRR_monom: assumes a: "a \ carrier R" and x: "x \ carrier R" shows "eval R R id x (monom P a d) = a \ x [^] d" proof - interpret UP_pre_univ_prop R R id by unfold_locales simp show ?thesis using assms by (simp add: eval_monom) qed lemma evalRR_one: assumes x: "x \ carrier R" shows "eval R R id x \\<^bsub>P\<^esub> = \" proof - interpret UP_pre_univ_prop R R id by unfold_locales simp interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x]) show ?thesis using assms by simp qed lemma carrier_evalRR: assumes x: "x \ carrier R" and "p \ carrier P" shows "eval R R id x p \ carrier R" proof - interpret UP_pre_univ_prop R R id by unfold_locales simp interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x]) show ?thesis using assms by simp qed lemmas evalRR_simps = evalRR_add evalRR_sub evalRR_mult evalRR_monom evalRR_one carrier_evalRR end section \Properties of the Euler \\\-function\ text_raw \\label{sec:euler-phi}\ text\ In this section we prove that for every positive natural number the equation $\sum_{d | n}^n \varphi(d) = n$ holds. \ lemma dvd_div_ge_1: fixes a b :: nat assumes "a \ 1" "b dvd a" shows "a div b \ 1" proof - from \b dvd a\ obtain c where "a = b * c" .. with \a \ 1\ show ?thesis by simp qed lemma dvd_nat_bounds: fixes n p :: nat assumes "p > 0" "n dvd p" shows "n > 0 \ n \ p" using assms by (simp add: dvd_pos_nat dvd_imp_le) (* TODO FIXME: This is the "totient" function from HOL-Number_Theory, but since part of HOL-Number_Theory depends on HOL-Algebra.Multiplicative_Group, there would be a cyclic dependency. *) definition phi' :: "nat => nat" where "phi' m = card {x. 1 \ x \ x \ m \ coprime x m}" notation (latex output) phi' ("\ _") lemma phi'_nonzero: assumes "m > 0" shows "phi' m > 0" proof - have "1 \ {x. 1 \ x \ x \ m \ coprime x m}" using assms by simp hence "card {x. 1 \ x \ x \ m \ coprime x m} > 0" by (auto simp: card_gt_0_iff) thus ?thesis unfolding phi'_def by simp qed lemma dvd_div_eq_1: fixes a b c :: nat assumes "c dvd a" "c dvd b" "a div c = b div c" shows "a = b" using assms dvd_mult_div_cancel[OF \c dvd a\] dvd_mult_div_cancel[OF \c dvd b\] by presburger lemma dvd_div_eq_2: fixes a b c :: nat assumes "c>0" "a dvd c" "b dvd c" "c div a = c div b" shows "a = b" proof - have "a > 0" "a \ c" using dvd_nat_bounds[OF assms(1-2)] by auto have "a*(c div a) = c" using assms dvd_mult_div_cancel by fastforce also have "\ = b*(c div a)" using assms dvd_mult_div_cancel by fastforce finally show "a = b" using \c>0\ dvd_div_ge_1[OF _ \a dvd c\] by fastforce qed lemma div_mult_mono: fixes a b c :: nat assumes "a > 0" "a\d" shows "a * b div d \ b" proof - have "a*b div d \ b*a div a" using assms div_le_mono2 mult.commute[of a b] by presburger thus ?thesis using assms by force qed text\ We arrive at the main result of this section: For every positive natural number the equation $\sum_{d | n}^n \varphi(d) = n$ holds. The outline of the proof for this lemma is as follows: We count the $n$ fractions $1/n$, $\ldots$, $(n-1)/n$, $n/n$. We analyze the reduced form $a/d = m/n$ for any of those fractions. We want to know how many fractions $m/n$ have the reduced form denominator $d$. The condition $1 \leq m \leq n$ is equivalent to the condition $1 \leq a \leq d$. Therefore we want to know how many $a$ with $1 \leq a \leq d$ exist, s.t. \<^term>\gcd a d = 1\. This number is exactly \<^term>\phi' d\. Finally, by counting the fractions $m/n$ according to their reduced form denominator, we get: @{term [display] "(\d | d dvd n . phi' d) = n"}. To formalize this proof in Isabelle, we analyze for an arbitrary divisor $d$ of $n$ \begin{itemize} \item the set of reduced form numerators \<^term>\{a. (1::nat) \ a \ a \ d \ coprime a d}\ \item the set of numerators $m$, for which $m/n$ has the reduced form denominator $d$, i.e. the set \<^term>\{m \ {1::nat .. n}. n div gcd m n = d}\ \end{itemize} We show that \<^term>\\a. a*n div d\ with the inverse \<^term>\\a. a div gcd a n\ is a bijection between theses sets, thus yielding the equality @{term [display] "phi' d = card {m \ {1 .. n}. n div gcd m n = d}"} This gives us @{term [display] "(\d | d dvd n . phi' d) = card (\d \ {d. d dvd n}. {m \ {1 .. n}. n div gcd m n = d})"} and by showing \<^term>\(\d \ {d. d dvd n}. {m \ {1::nat .. n}. n div gcd m n = d}) \ {1 .. n}\ (this is our counting argument) the thesis follows. \ lemma sum_phi'_factors: fixes n :: nat assumes "n > 0" shows "(\d | d dvd n. phi' d) = n" proof - { fix d assume "d dvd n" then obtain q where q: "n = d * q" .. have "card {a. 1 \ a \ a \ d \ coprime a d} = card {m \ {1 .. n}. n div gcd m n = d}" (is "card ?RF = card ?F") proof (rule card_bij_eq) { fix a b assume "a * n div d = b * n div d" hence "a * (n div d) = b * (n div d)" using dvd_div_mult[OF \d dvd n\] by (fastforce simp add: mult.commute) hence "a = b" using dvd_div_ge_1[OF _ \d dvd n\] \n>0\ by (simp add: mult.commute nat_mult_eq_cancel1) } thus "inj_on (\a. a*n div d) ?RF" unfolding inj_on_def by blast { fix a assume a: "a\?RF" hence "a * (n div d) \ 1" using \n>0\ dvd_div_ge_1[OF _ \d dvd n\] by simp hence ge_1: "a * n div d \ 1" by (simp add: \d dvd n\ div_mult_swap) have le_n: "a * n div d \ n" using div_mult_mono a by simp have "gcd (a * n div d) n = n div d * gcd a d" by (simp add: gcd_mult_distrib_nat q ac_simps) hence "n div gcd (a * n div d) n = d*n div (d*(n div d))" using a by simp hence "a * n div d \ ?F" using ge_1 le_n by (fastforce simp add: \d dvd n\) } thus "(\a. a*n div d) ` ?RF \ ?F" by blast { fix m l assume A: "m \ ?F" "l \ ?F" "m div gcd m n = l div gcd l n" hence "gcd m n = gcd l n" using dvd_div_eq_2[OF assms] by fastforce hence "m = l" using dvd_div_eq_1[of "gcd m n" m l] A(3) by fastforce } thus "inj_on (\a. a div gcd a n) ?F" unfolding inj_on_def by blast { fix m assume "m \ ?F" hence "m div gcd m n \ ?RF" using dvd_div_ge_1 by (fastforce simp add: div_le_mono div_gcd_coprime) } thus "(\a. a div gcd a n) ` ?F \ ?RF" by blast qed force+ } hence phi'_eq: "\d. d dvd n \ phi' d = card {m \ {1 .. n}. n div gcd m n = d}" unfolding phi'_def by presburger have fin: "finite {d. d dvd n}" using dvd_nat_bounds[OF \n>0\] by force have "(\d | d dvd n. phi' d) = card (\d \ {d. d dvd n}. {m \ {1 .. n}. n div gcd m n = d})" using card_UN_disjoint[OF fin, of "(\d. {m \ {1 .. n}. n div gcd m n = d})"] phi'_eq by fastforce also have "(\d \ {d. d dvd n}. {m \ {1 .. n}. n div gcd m n = d}) = {1 .. n}" (is "?L = ?R") proof show "?L \ ?R" proof fix m assume m: "m \ ?R" thus "m \ ?L" using dvd_triv_right[of "n div gcd m n" "gcd m n"] by simp qed qed fastforce finally show ?thesis by force qed + + section \Order of an Element of a Group\ text_raw \\label{sec:order-elem}\ context group begin definition (in group) ord :: "'a \ nat" where "ord x \ (@d. \n::nat. x [^] n = \ \ d dvd n)" lemma (in group) pow_eq_id: assumes "x \ carrier G" shows "x [^] n = \ \ (ord x) dvd n" proof (cases "\n::nat. pow G x n = one G \ n = 0") case True show ?thesis unfolding ord_def by (rule someI2 [where a=0]) (auto simp: True) next case False define N where "N \ LEAST n::nat. x [^] n = \ \ n > 0" have N: "x [^] N = \ \ N > 0" using False apply (simp add: N_def) by (metis (mono_tags, lifting) LeastI) have eq0: "n = 0" if "x [^] n = \" "n < N" for n using N_def not_less_Least that by fastforce show ?thesis unfolding ord_def proof (rule someI2 [where a = N], rule allI) fix n :: "nat" show "(x [^] n = \) \ (N dvd n)" proof (cases "n = 0") case False show ?thesis unfolding dvd_def proof safe assume 1: "x [^] n = \" have "x [^] n = x [^] (n mod N + N * (n div N))" by simp also have "\ = x [^] (n mod N) \ x [^] (N * (n div N))" by (simp add: assms nat_pow_mult) also have "\ = x [^] (n mod N)" by (metis N assms l_cancel_one nat_pow_closed nat_pow_one nat_pow_pow) finally have "x [^] (n mod N) = \" by (simp add: "1") then have "n mod N = 0" using N eq0 mod_less_divisor by blast then show "\k. n = N * k" by blast next fix k :: "nat" assume "n = N * k" with N show "x [^] (N * k) = \" by (metis assms nat_pow_one nat_pow_pow) qed qed simp qed blast qed lemma (in group) pow_ord_eq_1 [simp]: "x \ carrier G \ x [^] ord x = \" by (simp add: pow_eq_id) lemma (in group) int_pow_eq_id: assumes "x \ carrier G" shows "(pow G x i = one G \ int (ord x) dvd i)" proof (cases i rule: int_cases2) case (nonneg n) then show ?thesis by (simp add: int_pow_int pow_eq_id assms) next case (nonpos n) then have "x [^] i = inv (x [^] n)" by (simp add: assms int_pow_int int_pow_neg) then show ?thesis by (simp add: assms pow_eq_id nonpos) qed lemma (in group) int_pow_eq: "x \ carrier G \ (x [^] m = x [^] n) \ int (ord x) dvd (n - m)" apply (simp flip: int_pow_eq_id) by (metis int_pow_closed int_pow_diff inv_closed r_inv right_cancel) lemma (in group) ord_eq_0: "x \ carrier G \ (ord x = 0 \ (\n::nat. n \ 0 \ x [^] n \ \))" by (auto simp: pow_eq_id) lemma (in group) ord_unique: "x \ carrier G \ ord x = d \ (\n. pow G x n = one G \ d dvd n)" by (meson dvd_antisym dvd_refl pow_eq_id) lemma (in group) ord_eq_1: "x \ carrier G \ (ord x = 1 \ x = \)" by (metis pow_eq_id nat_dvd_1_iff_1 nat_pow_eone) lemma (in group) ord_id [simp]: "ord (one G) = 1" using ord_eq_1 by blast lemma (in group) ord_inv [simp]: "x \ carrier G \ ord (m_inv G x) = ord x" by (simp add: ord_unique pow_eq_id nat_pow_inv) lemma (in group) ord_pow: assumes "x \ carrier G" "k dvd ord x" "k \ 0" shows "ord (pow G x k) = ord x div k" proof - have "(x [^] k) [^] (ord x div k) = \" using assms by (simp add: nat_pow_pow) moreover have "ord x dvd k * ord (x [^] k)" by (metis assms(1) pow_ord_eq_1 pow_eq_id nat_pow_closed nat_pow_pow) ultimately show ?thesis by (metis assms div_dvd_div dvd_antisym dvd_triv_left pow_eq_id nat_pow_closed nonzero_mult_div_cancel_left) qed lemma (in group) ord_mul_divides: assumes eq: "x \ y = y \ x" and xy: "x \ carrier G" "y \ carrier G" shows "ord (x \ y) dvd (ord x * ord y)" apply (simp add: xy flip: pow_eq_id eq) by (metis dvd_triv_left dvd_triv_right eq pow_eq_id one_closed pow_mult_distrib r_one xy) lemma (in comm_group) abelian_ord_mul_divides: "\x \ carrier G; y \ carrier G\ \ ord (x \ y) dvd (ord x * ord y)" by (simp add: ord_mul_divides m_comm) lemma ord_inj: assumes a: "a \ carrier G" shows "inj_on (\ x . a [^] x) {0 .. ord a - 1}" proof - let ?M = "Max (ord ` carrier G)" have "finite {d \ {..?M}. a [^] d = \}" by auto have *: False if A: "x < y" "x \ {0 .. ord a - 1}" "y \ {0 .. ord a - 1}" "a [^] x = a [^] y" for x y proof - have "y - x < ord a" using that by auto moreover have "a [^] (y-x) = \" using a A by (simp add: pow_eq_div2) ultimately have "min (y - x) (ord a) = ord a" using A(1) a pow_eq_id by auto with \y - x < ord a\ show False by linarith qed show ?thesis unfolding inj_on_def by (metis nat_neq_iff *) qed lemma ord_inj': assumes a: "a \ carrier G" shows "inj_on (\ x . a [^] x) {1 .. ord a}" proof (rule inj_onI, rule ccontr) fix x y :: nat assume A: "x \ {1 .. ord a}" "y \ {1 .. ord a}" "a [^] x = a [^] y" "x\y" { assume "x < ord a" "y < ord a" hence False using ord_inj[OF assms] A unfolding inj_on_def by fastforce } moreover { assume "x = ord a" "y < ord a" hence "a [^] y = a [^] (0::nat)" using pow_ord_eq_1 A by (simp add: a) hence "y=0" using ord_inj[OF assms] \y < ord a\ unfolding inj_on_def by force hence False using A by fastforce } moreover { assume "y = ord a" "x < ord a" hence "a [^] x = a [^] (0::nat)" using pow_ord_eq_1 A by (simp add: a) hence "x=0" using ord_inj[OF assms] \x < ord a\ unfolding inj_on_def by force hence False using A by fastforce } ultimately show False using A by force qed lemma (in group) ord_ge_1: assumes finite: "finite (carrier G)" and a: "a \ carrier G" shows "ord a \ 1" proof - have "((\n::nat. a [^] n) ` {0<..}) \ carrier G" using a by blast then have "finite ((\n::nat. a [^] n) ` {0<..})" using finite_subset finite by auto then have "\ inj_on (\n::nat. a [^] n) {0<..}" using finite_imageD infinite_Ioi by blast then obtain i j::nat where "i \ j" "a [^] i = a [^] j" by (auto simp: inj_on_def) then have "\n::nat. n>0 \ a [^] n = \" by (metis a diffs0_imp_equal pow_eq_div2 neq0_conv) then have "ord a \ 0" by (simp add: ord_eq_0 [OF a]) then show ?thesis by simp qed lemma ord_elems: assumes "finite (carrier G)" "a \ carrier G" shows "{a[^]x | x. x \ (UNIV :: nat set)} = {a[^]x | x. x \ {0 .. ord a - 1}}" (is "?L = ?R") proof show "?R \ ?L" by blast { fix y assume "y \ ?L" then obtain x::nat where x: "y = a[^]x" by auto define r q where "r = x mod ord a" and "q = x div ord a" then have "x = q * ord a + r" by (simp add: div_mult_mod_eq) hence "y = (a[^]ord a)[^]q \ a[^]r" using x assms by (metis mult.commute nat_pow_mult nat_pow_pow) hence "y = a[^]r" using assms by (simp add: pow_ord_eq_1) have "r < ord a" using ord_ge_1[OF assms] by (simp add: r_def) hence "r \ {0 .. ord a - 1}" by (force simp: r_def) hence "y \ {a[^]x | x. x \ {0 .. ord a - 1}}" using \y=a[^]r\ by blast } thus "?L \ ?R" by auto qed +lemma (in group) + assumes "x \ carrier G" + shows finite_cyclic_subgroup: + "finite(carrier(subgroup_generated G {x})) \ (\n::nat. n \ 0 \ x [^] n = \)" (is "?fin \ ?nat1") + and infinite_cyclic_subgroup: + "infinite(carrier(subgroup_generated G {x})) \ (\m n::nat. x [^] m = x [^] n \ m = n)" (is "\ ?fin \ ?nateq") + and finite_cyclic_subgroup_int: + "finite(carrier(subgroup_generated G {x})) \ (\i::int. i \ 0 \ x [^] i = \)" (is "?fin \ ?int1") + and infinite_cyclic_subgroup_int: + "infinite(carrier(subgroup_generated G {x})) \ (\i j::int. x [^] i = x [^] j \ i = j)" (is "\ ?fin \ ?inteq") +proof - + have 1: "\ ?fin" if ?nateq + proof - + have "infinite (range (\n::nat. x [^] n))" + using that range_inj_infinite [of "(\n::nat. x [^] n)"] by (auto simp: inj_on_def) + moreover have "range (\n::nat. x [^] n) \ range (\i::int. x [^] i)" + apply clarify + by (metis assms group.int_pow_neg int_pow_closed int_pow_neg_int is_group local.inv_equality nat_pow_closed r_inv rangeI) + ultimately show ?thesis + using carrier_subgroup_generated_by_singleton [OF assms] finite_subset by auto + qed + have 2: "m = n" if mn: "x [^] m = x [^] n" and eq [rule_format]: "?inteq" for m n::nat + using eq [of "int m" "int n"] + by (simp add: int_pow_int mn) + have 3: ?nat1 if non: "\ ?inteq" + proof - + obtain i j::int where eq: "x [^] i = x [^] j" and "i \ j" + using non by auto + show ?thesis + proof (cases i j rule: linorder_cases) + case less + then have [simp]: "x [^] (j - i) = \" + by (simp add: eq assms int_pow_diff) + show ?thesis + using less by (rule_tac x="nat (j-i)" in exI) auto + next + case greater + then have [simp]: "x [^] (i - j) = \" + by (simp add: eq assms int_pow_diff) + then show ?thesis + using greater by (rule_tac x="nat (i-j)" in exI) auto + qed (use \i \ j\ in auto) + qed + have 4: "\i::int. (i \ 0) \ x [^] i = \" if "n \ 0" "x [^] n = \" for n::nat + apply (rule_tac x="int n" in exI) + by (simp add: int_pow_int that) + have 5: "finite (carrier (subgroup_generated G {x}))" if "i \ 0" and 1: "x [^] i = \" for i::int + proof - + obtain n::nat where n: "n > 0" "x [^] n = \" + using "1" "3" \i \ 0\ by fastforce + have "x [^] a \ ([^]) x ` {0.. {0.. ([^]) x ` {0.. ?nat1" "\ ?fin \ ?nateq" "?fin \ ?int1" "\ ?fin \ ?inteq" + using 1 2 3 4 5 by meson+ +qed + +lemma (in group) finite_cyclic_subgroup_order: + "x \ carrier G \ finite(carrier(subgroup_generated G {x})) \ ord x \ 0" + by (simp add: finite_cyclic_subgroup ord_eq_0) + +lemma (in group) infinite_cyclic_subgroup_order: + "x \ carrier G \ infinite (carrier(subgroup_generated G {x})) \ ord x = 0" + by (simp add: finite_cyclic_subgroup_order) + lemma generate_pow_on_finite_carrier: \<^marker>\contributor \Paulo Emílio de Vilhena\\ assumes "finite (carrier G)" and a: "a \ carrier G" shows "generate G { a } = { a [^] k | k. k \ (UNIV :: nat set) }" proof show "{ a [^] k | k. k \ (UNIV :: nat set) } \ generate G { a }" proof fix b assume "b \ { a [^] k | k. k \ (UNIV :: nat set) }" then obtain k :: nat where "b = a [^] k" by blast hence "b = a [^] (int k)" by (simp add: int_pow_int) thus "b \ generate G { a }" unfolding generate_pow[OF a] by blast qed next show "generate G { a } \ { a [^] k | k. k \ (UNIV :: nat set) }" proof fix b assume "b \ generate G { a }" then obtain k :: int where k: "b = a [^] k" unfolding generate_pow[OF a] by blast show "b \ { a [^] k | k. k \ (UNIV :: nat set) }" proof (cases "k < 0") assume "\ k < 0" hence "b = a [^] (nat k)" by (simp add: k) thus ?thesis by blast next assume "k < 0" hence b: "b = inv (a [^] (nat (- k)))" using k a by (auto simp: int_pow_neg) obtain m where m: "ord a * m \ nat (- k)" by (metis assms mult.left_neutral mult_le_mono1 ord_ge_1) hence "a [^] (ord a * m) = \" by (metis a nat_pow_one nat_pow_pow pow_ord_eq_1) then obtain k' :: nat where "(a [^] (nat (- k))) \ (a [^] k') = \" using m a nat_le_iff_add nat_pow_mult by auto hence "b = a [^] k'" using b a by (metis inv_unique' nat_pow_closed nat_pow_comm) thus "b \ { a [^] k | k. k \ (UNIV :: nat set) }" by blast qed qed qed -lemma generate_pow_card: \<^marker>\contributor \Paulo Emílio de Vilhena\\ - assumes "finite (carrier G)" and a: "a \ carrier G" - shows "ord a = card (generate G { a })" -proof - - have "generate G { a } = (([^]) a) ` {0..ord a - 1}" - using generate_pow_on_finite_carrier[OF assms] unfolding ord_elems[OF assms] by auto - thus ?thesis - using ord_inj[OF a] ord_ge_1[OF assms] by (simp add: card_image) +lemma ord_elems_inf_carrier: + assumes "a \ carrier G" "ord a \ 0" + shows "{a[^]x | x. x \ (UNIV :: nat set)} = {a[^]x | x. x \ {0 .. ord a - 1}}" (is "?L = ?R") +proof + show "?R \ ?L" by blast + { fix y assume "y \ ?L" + then obtain x::nat where x: "y = a[^]x" by auto + define r q where "r = x mod ord a" and "q = x div ord a" + then have "x = q * ord a + r" + by (simp add: div_mult_mod_eq) + hence "y = (a[^]ord a)[^]q \ a[^]r" + using x assms by (metis mult.commute nat_pow_mult nat_pow_pow) + hence "y = a[^]r" using assms by simp + have "r < ord a" using assms by (simp add: r_def) + hence "r \ {0 .. ord a - 1}" by (force simp: r_def) + hence "y \ {a[^]x | x. x \ {0 .. ord a - 1}}" using \y=a[^]r\ by blast + } + thus "?L \ ?R" by auto qed -lemma ord_dvd_group_order: - assumes "a \ carrier G" - shows "(ord a) dvd (order G)" -proof (cases "finite (carrier G)") +lemma generate_pow_nat: + assumes a: "a \ carrier G" and "ord a \ 0" + shows "generate G { a } = { a [^] k | k. k \ (UNIV :: nat set) }" +proof + show "{ a [^] k | k. k \ (UNIV :: nat set) } \ generate G { a }" + proof + fix b assume "b \ { a [^] k | k. k \ (UNIV :: nat set) }" + then obtain k :: nat where "b = a [^] k" by blast + hence "b = a [^] (int k)" + by (simp add: int_pow_int) + thus "b \ generate G { a }" + unfolding generate_pow[OF a] by blast + qed +next + show "generate G { a } \ { a [^] k | k. k \ (UNIV :: nat set) }" + proof + fix b assume "b \ generate G { a }" + then obtain k :: int where k: "b = a [^] k" + unfolding generate_pow[OF a] by blast + show "b \ { a [^] k | k. k \ (UNIV :: nat set) }" + proof (cases "k < 0") + assume "\ k < 0" + hence "b = a [^] (nat k)" + by (simp add: k) + thus ?thesis by blast + next + assume "k < 0" + hence b: "b = inv (a [^] (nat (- k)))" + using k a by (auto simp: int_pow_neg) + obtain m where m: "ord a * m \ nat (- k)" + by (metis assms(2) dvd_imp_le dvd_triv_right le_zero_eq mult_eq_0_iff not_gr_zero) + hence "a [^] (ord a * m) = \" + by (metis a nat_pow_one nat_pow_pow pow_ord_eq_1) + then obtain k' :: nat where "(a [^] (nat (- k))) \ (a [^] k') = \" + using m a nat_le_iff_add nat_pow_mult by auto + hence "b = a [^] k'" + using b a by (metis inv_unique' nat_pow_closed nat_pow_comm) + thus "b \ { a [^] k | k. k \ (UNIV :: nat set) }" by blast + qed + qed +qed + +lemma generate_pow_card: + assumes a: "a \ carrier G" + shows "ord a = card (generate G { a })" +proof (cases "ord a = 0") case True + then have "infinite (carrier (subgroup_generated G {a}))" + using infinite_cyclic_subgroup_order[OF a] by auto + then have "infinite (generate G {a})" + unfolding subgroup_generated_def + using a by simp then show ?thesis - using lagrange[OF generate_is_subgroup[of "{a}"]] assms - unfolding generate_pow_card[OF True assms] - by (metis dvd_triv_right empty_subsetI insert_subset) + using `ord a = 0` by auto next case False - then show ?thesis - using order_gt_0_iff_finite by auto + note finite_subgroup = this + then have "generate G { a } = (([^]) a) ` {0..ord a - 1}" + using generate_pow_nat ord_elems_inf_carrier a by auto + hence "card (generate G {a}) = card {0..ord a - 1}" + using ord_inj[OF a] card_image by metis + also have "... = ord a" using finite_subgroup by auto + finally show ?thesis.. qed +lemma (in group) cyclic_order_is_ord: + assumes "g \ carrier G" + shows "ord g = order (subgroup_generated G {g})" + unfolding order_def subgroup_generated_def + using assms generate_pow_card by simp + +lemma ord_dvd_group_order: + assumes "a \ carrier G" shows "(ord a) dvd (order G)" + using lagrange[OF generate_is_subgroup[of "{a}"]] assms + unfolding generate_pow_card[OF assms] + by (metis dvd_triv_right empty_subsetI insert_subset) + lemma (in group) pow_order_eq_1: assumes "a \ carrier G" shows "a [^] order G = \" using assms by (metis nat_pow_pow ord_dvd_group_order pow_ord_eq_1 dvdE nat_pow_one) lemma dvd_gcd: fixes a b :: nat obtains q where "a * (b div gcd a b) = b*q" proof have "a * (b div gcd a b) = (a div gcd a b) * b" by (simp add: div_mult_swap dvd_div_mult) also have "\ = b * (a div gcd a b)" by simp finally show "a * (b div gcd a b) = b * (a div gcd a b) " . qed lemma (in group) ord_le_group_order: assumes finite: "finite (carrier G)" and a: "a \ carrier G" shows "ord a \ order G" by (simp add: a dvd_imp_le local.finite ord_dvd_group_order order_gt_0_iff_finite) lemma (in group) ord_pow_gen: assumes "x \ carrier G" shows "ord (pow G x k) = (if k = 0 then 1 else ord x div gcd (ord x) k)" proof - have "ord (x [^] k) = ord x div gcd (ord x) k" if "0 < k" proof - have "(d dvd k * n) = (d div gcd (d) k dvd n)" for d n using that by (simp add: div_dvd_iff_mult gcd_mult_distrib_nat mult.commute) then show ?thesis using that by (auto simp add: assms ord_unique nat_pow_pow pow_eq_id) qed then show ?thesis by auto qed lemma (in group) assumes finite': "finite (carrier G)" "a \ carrier G" shows pow_ord_eq_ord_iff: "group.ord G (a [^] k) = ord a \ coprime k (ord a)" (is "?L \ ?R") using assms ord_ge_1 [OF assms] by (auto simp: div_eq_dividend_iff ord_pow_gen coprime_iff_gcd_eq_1 gcd.commute split: if_split_asm) lemma element_generates_subgroup: assumes finite[simp]: "finite (carrier G)" assumes a[simp]: "a \ carrier G" shows "subgroup {a [^] i | i. i \ {0 .. ord a - 1}} G" using generate_is_subgroup[of "{ a }"] assms(2) generate_pow_on_finite_carrier[OF assms] unfolding ord_elems[OF assms] by auto end section \Number of Roots of a Polynomial\ text_raw \\label{sec:number-roots}\ definition mult_of :: "('a, 'b) ring_scheme \ 'a monoid" where "mult_of R \ \ carrier = carrier R - {\\<^bsub>R\<^esub>}, mult = mult R, one = \\<^bsub>R\<^esub>\" lemma carrier_mult_of [simp]: "carrier (mult_of R) = carrier R - {\\<^bsub>R\<^esub>}" by (simp add: mult_of_def) lemma mult_mult_of [simp]: "mult (mult_of R) = mult R" by (simp add: mult_of_def) lemma nat_pow_mult_of: "([^]\<^bsub>mult_of R\<^esub>) = (([^]\<^bsub>R\<^esub>) :: _ \ nat \ _)" by (simp add: mult_of_def fun_eq_iff nat_pow_def) lemma one_mult_of [simp]: "\\<^bsub>mult_of R\<^esub> = \\<^bsub>R\<^esub>" by (simp add: mult_of_def) lemmas mult_of_simps = carrier_mult_of mult_mult_of nat_pow_mult_of one_mult_of context field begin lemma mult_of_is_Units: "mult_of R = units_of R" unfolding mult_of_def units_of_def using field_Units by auto lemma m_inv_mult_of: "\x. x \ carrier (mult_of R) \ m_inv (mult_of R) x = m_inv R x" using mult_of_is_Units units_of_inv unfolding units_of_def by simp lemma (in field) field_mult_group: "group (mult_of R)" proof (rule groupI) show "\y\carrier (mult_of R). y \\<^bsub>mult_of R\<^esub> x = \\<^bsub>mult_of R\<^esub>" if "x \ carrier (mult_of R)" for x using group.l_inv_ex mult_of_is_Units that units_group by fastforce qed (auto simp: m_assoc dest: integral) lemma finite_mult_of: "finite (carrier R) \ finite (carrier (mult_of R))" by simp lemma order_mult_of: "finite (carrier R) \ order (mult_of R) = order R - 1" unfolding order_def carrier_mult_of by (simp add: card.remove) end lemma (in monoid) Units_pow_closed : fixes d :: nat assumes "x \ Units G" shows "x [^] d \ Units G" by (metis assms group.is_monoid monoid.nat_pow_closed units_group units_of_carrier units_of_pow) lemma (in ring) r_right_minus_eq[simp]: assumes "a \ carrier R" "b \ carrier R" shows "a \ b = \ \ a = b" using assms by (metis a_minus_def add.inv_closed minus_equality r_neg) context UP_cring begin lemma is_UP_cring: "UP_cring R" by (unfold_locales) lemma is_UP_ring: shows "UP_ring R" by (unfold_locales) end context UP_domain begin lemma roots_bound: assumes f [simp]: "f \ carrier P" assumes f_not_zero: "f \ \\<^bsub>P\<^esub>" assumes finite: "finite (carrier R)" shows "finite {a \ carrier R . eval R R id a f = \} \ card {a \ carrier R . eval R R id a f = \} \ deg R f" using f f_not_zero proof (induction "deg R f" arbitrary: f) case 0 have "\x. eval R R id x f \ \" proof - fix x have "(\i\{..deg R f}. id (coeff P f i) \ x [^] i) \ \" using 0 lcoeff_nonzero_nonzero[where p = f] by simp thus "eval R R id x f \ \" using 0 unfolding eval_def P_def by simp qed then have *: "{a \ carrier R. eval R R (\a. a) a f = \} = {}" by (auto simp: id_def) show ?case by (simp add: *) next case (Suc x) show ?case proof (cases "\ a \ carrier R . eval R R id a f = \") case True then obtain a where a_carrier[simp]: "a \ carrier R" and a_root: "eval R R id a f = \" by blast have R_not_triv: "carrier R \ {\}" by (metis R.one_zeroI R.zero_not_one) obtain q where q: "(q \ carrier P)" and f: "f = (monom P \\<^bsub>R\<^esub> 1 \\<^bsub> P\<^esub> monom P a 0) \\<^bsub>P\<^esub> q \\<^bsub>P\<^esub> monom P (eval R R id a f) 0" using remainder_theorem[OF Suc.prems(1) a_carrier R_not_triv] by auto hence lin_fac: "f = (monom P \\<^bsub>R\<^esub> 1 \\<^bsub> P\<^esub> monom P a 0) \\<^bsub>P\<^esub> q" using q by (simp add: a_root) have deg: "deg R (monom P \\<^bsub>R\<^esub> 1 \\<^bsub> P\<^esub> monom P a 0) = 1" using a_carrier by (simp add: deg_minus_eq) hence mon_not_zero: "(monom P \\<^bsub>R\<^esub> 1 \\<^bsub> P\<^esub> monom P a 0) \ \\<^bsub>P\<^esub>" by (fastforce simp del: r_right_minus_eq) have q_not_zero: "q \ \\<^bsub>P\<^esub>" using Suc by (auto simp add : lin_fac) hence "deg R q = x" using Suc deg deg_mult[OF mon_not_zero q_not_zero _ q] by (simp add : lin_fac) hence q_IH: "finite {a \ carrier R . eval R R id a q = \} \ card {a \ carrier R . eval R R id a q = \} \ x" using Suc q q_not_zero by blast have subs: "{a \ carrier R . eval R R id a f = \} \ {a \ carrier R . eval R R id a q = \} \ {a}" (is "?L \ ?R \ {a}") using a_carrier \q \ _\ by (auto simp: evalRR_simps lin_fac R.integral_iff) have "{a \ carrier R . eval R R id a f = \} \ insert a {a \ carrier R . eval R R id a q = \}" using subs by auto hence "card {a \ carrier R . eval R R id a f = \} \ card (insert a {a \ carrier R . eval R R id a q = \})" using q_IH by (blast intro: card_mono) also have "\ \ deg R f" using q_IH \Suc x = _\ by (simp add: card_insert_if) finally show ?thesis using q_IH \Suc x = _\ using finite by force next case False hence "card {a \ carrier R. eval R R id a f = \} = 0" using finite by auto also have "\ \ deg R f" by simp finally show ?thesis using finite by auto qed qed end lemma (in domain) num_roots_le_deg : fixes p d :: nat assumes finite: "finite (carrier R)" assumes d_neq_zero: "d \ 0" shows "card {x \ carrier R. x [^] d = \} \ d" proof - let ?f = "monom (UP R) \\<^bsub>R\<^esub> d \\<^bsub> (UP R)\<^esub> monom (UP R) \\<^bsub>R\<^esub> 0" have one_in_carrier: "\ \ carrier R" by simp interpret R: UP_domain R "UP R" by (unfold_locales) have "deg R ?f = d" using d_neq_zero by (simp add: R.deg_minus_eq) hence f_not_zero: "?f \ \\<^bsub>UP R\<^esub>" using d_neq_zero by (auto simp add : R.deg_nzero_nzero) have roots_bound: "finite {a \ carrier R . eval R R id a ?f = \} \ card {a \ carrier R . eval R R id a ?f = \} \ deg R ?f" using finite by (intro R.roots_bound[OF _ f_not_zero]) simp have subs: "{x \ carrier R. x [^] d = \} \ {a \ carrier R . eval R R id a ?f = \}" by (auto simp: R.evalRR_simps) then have "card {x \ carrier R. x [^] d = \} \ card {a \ carrier R. eval R R id a ?f = \}" using finite by (simp add : card_mono) thus ?thesis using \deg R ?f = d\ roots_bound by linarith qed section \The Multiplicative Group of a Field\ text_raw \\label{sec:mult-group}\ text \ In this section we show that the multiplicative group of a finite field is generated by a single element, i.e. it is cyclic. The proof is inspired by the first proof given in the survey~@{cite "conrad-cyclicity"}. \ context field begin lemma num_elems_of_ord_eq_phi': assumes finite: "finite (carrier R)" and dvd: "d dvd order (mult_of R)" and exists: "\a\carrier (mult_of R). group.ord (mult_of R) a = d" shows "card {a \ carrier (mult_of R). group.ord (mult_of R) a = d} = phi' d" proof - note mult_of_simps[simp] have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of) interpret G:group "mult_of R" rewrites "([^]\<^bsub>mult_of R\<^esub>) = (([^]) :: _ \ nat \ _)" and "\\<^bsub>mult_of R\<^esub> = \" by (rule field_mult_group) simp_all from exists obtain a where a: "a \ carrier (mult_of R)" and ord_a: "group.ord (mult_of R) a = d" by (auto simp add: card_gt_0_iff) have set_eq1: "{a[^]n| n. n \ {1 .. d}} = {x \ carrier (mult_of R). x [^] d = \}" proof (rule card_seteq) show "finite {x \ carrier (mult_of R). x [^] d = \}" using finite by auto show "{a[^]n| n. n \ {1 ..d}} \ {x \ carrier (mult_of R). x[^]d = \}" proof fix x assume "x \ {a[^]n | n. n \ {1 .. d}}" then obtain n where n: "x = a[^]n \ n \ {1 .. d}" by auto have "x[^]d =(a[^]d)[^]n" using n a ord_a by (simp add:nat_pow_pow mult.commute) hence "x[^]d = \" using ord_a G.pow_ord_eq_1[OF a] by fastforce thus "x \ {x \ carrier (mult_of R). x[^]d = \}" using G.nat_pow_closed[OF a] n by blast qed show "card {x \ carrier (mult_of R). x [^] d = \} \ card {a[^]n | n. n \ {1 .. d}}" proof - have *: "{a[^]n | n. n \ {1 .. d }} = ((\ n. a[^]n) ` {1 .. d})" by auto have "0 < order (mult_of R)" unfolding order_mult_of[OF finite] using card_mono[OF finite, of "{\, \}"] by (simp add: order_def) have "card {x \ carrier (mult_of R). x [^] d = \} \ card {x \ carrier R. x [^] d = \}" using finite by (auto intro: card_mono) also have "\ \ d" using \0 < order (mult_of R)\ num_roots_le_deg[OF finite, of d] by (simp add : dvd_pos_nat[OF _ \d dvd order (mult_of R)\]) finally show ?thesis using G.ord_inj'[OF a] ord_a * by (simp add: card_image) qed qed have set_eq2: "{x \ carrier (mult_of R) . group.ord (mult_of R) x = d} = (\ n . a[^]n) ` {n \ {1 .. d}. group.ord (mult_of R) (a[^]n) = d}" (is "?L = ?R") proof { fix x assume x: "x \ (carrier (mult_of R)) \ group.ord (mult_of R) x = d" hence "x \ {x \ carrier (mult_of R). x [^] d = \}" by (simp add: G.pow_ord_eq_1[of x, symmetric]) then obtain n where n: "x = a[^]n \ n \ {1 .. d}" using set_eq1 by blast hence "x \ ?R" using x by fast } thus "?L \ ?R" by blast show "?R \ ?L" using a by (auto simp add: carrier_mult_of[symmetric] simp del: carrier_mult_of) qed have "inj_on (\ n . a[^]n) {n \ {1 .. d}. group.ord (mult_of R) (a[^]n) = d}" using G.ord_inj'[OF a, unfolded ord_a] unfolding inj_on_def by fast hence "card ((\n. a[^]n) ` {n \ {1 .. d}. group.ord (mult_of R) (a[^]n) = d}) = card {k \ {1 .. d}. group.ord (mult_of R) (a[^]k) = d}" using card_image by blast thus ?thesis using set_eq2 G.pow_ord_eq_ord_iff[OF finite' \a \ _\, unfolded ord_a] by (simp add: phi'_def) qed end theorem (in field) finite_field_mult_group_has_gen : assumes finite: "finite (carrier R)" shows "\ a \ carrier (mult_of R) . carrier (mult_of R) = {a[^]i | i::nat . i \ UNIV}" proof - note mult_of_simps[simp] have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of) interpret G: group "mult_of R" rewrites "([^]\<^bsub>mult_of R\<^esub>) = (([^]) :: _ \ nat \ _)" and "\\<^bsub>mult_of R\<^esub> = \" by (rule field_mult_group) (simp_all add: fun_eq_iff nat_pow_def) let ?N = "\ x . card {a \ carrier (mult_of R). group.ord (mult_of R) a = x}" have "0 < order R - 1" unfolding order_def using card_mono[OF finite, of "{\, \}"] by simp then have *: "0 < order (mult_of R)" using assms by (simp add: order_mult_of) have fin: "finite {d. d dvd order (mult_of R) }" using dvd_nat_bounds[OF *] by force have "(\d | d dvd order (mult_of R). ?N d) = card (UN d:{d . d dvd order (mult_of R) }. {a \ carrier (mult_of R). group.ord (mult_of R) a = d})" (is "_ = card ?U") using fin finite by (subst card_UN_disjoint) auto also have "?U = carrier (mult_of R)" proof { fix x assume x: "x \ carrier (mult_of R)" hence x': "x\carrier (mult_of R)" by simp then have "group.ord (mult_of R) x dvd order (mult_of R)" using G.ord_dvd_group_order by blast hence "x \ ?U" using dvd_nat_bounds[of "order (mult_of R)" "group.ord (mult_of R) x"] x by blast } thus "carrier (mult_of R) \ ?U" by blast qed auto also have "card ... = order (mult_of R)" using order_mult_of finite' by (simp add: order_def) finally have sum_Ns_eq: "(\d | d dvd order (mult_of R). ?N d) = order (mult_of R)" . { fix d assume d: "d dvd order (mult_of R)" have "card {a \ carrier (mult_of R). group.ord (mult_of R) a = d} \ phi' d" proof cases assume "card {a \ carrier (mult_of R). group.ord (mult_of R) a = d} = 0" thus ?thesis by presburger next assume "card {a \ carrier (mult_of R). group.ord (mult_of R) a = d} \ 0" hence "\a \ carrier (mult_of R). group.ord (mult_of R) a = d" by (auto simp: card_eq_0_iff) thus ?thesis using num_elems_of_ord_eq_phi'[OF finite d] by auto qed } hence all_le: "\i. i \ {d. d dvd order (mult_of R) } \ (\i. card {a \ carrier (mult_of R). group.ord (mult_of R) a = i}) i \ (\i. phi' i) i" by fast hence le: "(\i | i dvd order (mult_of R). ?N i) \ (\i | i dvd order (mult_of R). phi' i)" using sum_mono[of "{d . d dvd order (mult_of R)}" "\i. card {a \ carrier (mult_of R). group.ord (mult_of R) a = i}"] by presburger have "order (mult_of R) = (\d | d dvd order (mult_of R). phi' d)" using * by (simp add: sum_phi'_factors) hence eq: "(\i | i dvd order (mult_of R). ?N i) = (\i | i dvd order (mult_of R). phi' i)" using le sum_Ns_eq by presburger have "\i. i \ {d. d dvd order (mult_of R) } \ ?N i = (\i. phi' i) i" proof (rule ccontr) fix i assume i1: "i \ {d. d dvd order (mult_of R)}" and "?N i \ phi' i" hence "?N i = 0" using num_elems_of_ord_eq_phi'[OF finite, of i] by (auto simp: card_eq_0_iff) moreover have "0 < i" using * i1 by (simp add: dvd_nat_bounds[of "order (mult_of R)" i]) ultimately have "?N i < phi' i" using phi'_nonzero by presburger hence "(\i | i dvd order (mult_of R). ?N i) < (\i | i dvd order (mult_of R). phi' i)" using sum_strict_mono_ex1[OF fin, of "?N" "\ i . phi' i"] i1 all_le by auto thus False using eq by force qed hence "?N (order (mult_of R)) > 0" using * by (simp add: phi'_nonzero) then obtain a where a: "a \ carrier (mult_of R)" and a_ord: "group.ord (mult_of R) a = order (mult_of R)" by (auto simp add: card_gt_0_iff) hence set_eq: "{a[^]i | i::nat. i \ UNIV} = (\x. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}" using G.ord_elems[OF finite'] by auto have card_eq: "card ((\x. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 .. group.ord (mult_of R) a - 1}" by (intro card_image G.ord_inj finite' a) hence "card ((\ x . a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 ..order (mult_of R) - 1}" using assms by (simp add: card_eq a_ord) hence card_R_minus_1: "card {a[^]i | i::nat. i \ UNIV} = order (mult_of R)" using * by (subst set_eq) auto have **: "{a[^]i | i::nat. i \ UNIV} \ carrier (mult_of R)" using G.nat_pow_closed[OF a] by auto with _ have "carrier (mult_of R) = {a[^]i|i::nat. i \ UNIV}" by (rule card_seteq[symmetric]) (simp_all add: card_R_minus_1 finite order_def del: UNIV_I) thus ?thesis using a by blast qed end diff --git a/src/HOL/Complex_Analysis/Cauchy_Integral_Theorem.thy b/src/HOL/Complex_Analysis/Cauchy_Integral_Theorem.thy --- a/src/HOL/Complex_Analysis/Cauchy_Integral_Theorem.thy +++ b/src/HOL/Complex_Analysis/Cauchy_Integral_Theorem.thy @@ -1,1592 +1,1630 @@ section \Complex Path Integrals and Cauchy's Integral Theorem\ text\By John Harrison et al. Ported from HOL Light by L C Paulson (2015)\ theory Cauchy_Integral_Theorem imports "HOL-Analysis.Analysis" Contour_Integration begin lemma leibniz_rule_holomorphic: fixes f::"complex \ 'b::euclidean_space \ complex" assumes "\x t. x \ U \ t \ cbox a b \ ((\x. f x t) has_field_derivative fx x t) (at x within U)" assumes "\x. x \ U \ (f x) integrable_on cbox a b" assumes "continuous_on (U \ (cbox a b)) (\(x, t). fx x t)" assumes "convex U" shows "(\x. integral (cbox a b) (f x)) holomorphic_on U" using leibniz_rule_field_differentiable[OF assms(1-3) _ assms(4)] by (auto simp: holomorphic_on_def) lemma Ln_measurable [measurable]: "Ln \ measurable borel borel" proof - have *: "Ln (-of_real x) = of_real (ln x) + \ * pi" if "x > 0" for x using that by (subst Ln_minus) (auto simp: Ln_of_real) have **: "Ln (of_real x) = of_real (ln (-x)) + \ * pi" if "x < 0" for x using *[of "-x"] that by simp have cont: "(\x. indicat_real (- \\<^sub>\\<^sub>0) x *\<^sub>R Ln x) \ borel_measurable borel" by (intro borel_measurable_continuous_on_indicator continuous_intros) auto have "(\x. if x \ \\<^sub>\\<^sub>0 then ln (-Re x) + \ * pi else indicator (-\\<^sub>\\<^sub>0) x *\<^sub>R Ln x) \ borel \\<^sub>M borel" (is "?f \ _") by (rule measurable_If_set[OF _ cont]) auto hence "(\x. if x = 0 then Ln 0 else ?f x) \ borel \\<^sub>M borel" by measurable also have "(\x. if x = 0 then Ln 0 else ?f x) = Ln" by (auto simp: fun_eq_iff ** nonpos_Reals_def) finally show ?thesis . qed lemma powr_complex_measurable [measurable]: assumes [measurable]: "f \ measurable M borel" "g \ measurable M borel" shows "(\x. f x powr g x :: complex) \ measurable M borel" using assms by (simp add: powr_def) text\The special case of midpoints used in the main quadrisection\ lemma has_contour_integral_midpoint: assumes "(f has_contour_integral i) (linepath a (midpoint a b))" "(f has_contour_integral j) (linepath (midpoint a b) b)" shows "(f has_contour_integral (i + j)) (linepath a b)" - apply (rule has_contour_integral_split [where c = "midpoint a b" and k = "1/2"]) - using assms - apply (auto simp: midpoint_def algebra_simps scaleR_conv_of_real) - done +proof (rule has_contour_integral_split) + show "midpoint a b - a = (1/2) *\<^sub>R (b - a)" + using assms by (auto simp: midpoint_def scaleR_conv_of_real) +qed (use assms in auto) lemma contour_integral_midpoint: - "continuous_on (closed_segment a b) f - \ contour_integral (linepath a b) f = - contour_integral (linepath a (midpoint a b)) f + contour_integral (linepath (midpoint a b) b) f" - apply (rule contour_integral_split [where c = "midpoint a b" and k = "1/2"]) - apply (auto simp: midpoint_def algebra_simps scaleR_conv_of_real) - done + assumes "continuous_on (closed_segment a b) f" + shows "contour_integral (linepath a b) f = + contour_integral (linepath a (midpoint a b)) f + contour_integral (linepath (midpoint a b) b) f" +proof (rule contour_integral_split) + show "midpoint a b - a = (1/2) *\<^sub>R (b - a)" + using assms by (auto simp: midpoint_def scaleR_conv_of_real) +qed (use assms in auto) text\A couple of special case lemmas that are useful below\ lemma triangle_linear_has_chain_integral: "((\x. m*x + d) has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" - apply (rule Cauchy_theorem_primitive [of UNIV "\x. m/2 * x^2 + d*x"]) - apply (auto intro!: derivative_eq_intros) - done +proof (rule Cauchy_theorem_primitive) + show "\x. x \ UNIV \ ((\x. m / 2 * x\<^sup>2 + d * x) has_field_derivative m * x + d) (at x)" + by (auto intro!: derivative_eq_intros) +qed auto lemma has_chain_integral_chain_integral3: - "(f has_contour_integral i) (linepath a b +++ linepath b c +++ linepath c d) - \ contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c d) f = i" - apply (subst contour_integral_unique [symmetric], assumption) - apply (drule has_contour_integral_integrable) - apply (simp add: valid_path_join) - done + assumes "(f has_contour_integral i) (linepath a b +++ linepath b c +++ linepath c d)" + (is "(f has_contour_integral i) ?g") + shows "contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c d) f = i" + (is "?lhs = _") +proof - + have "f contour_integrable_on ?g" + using assms contour_integrable_on_def by blast + then have "?lhs = contour_integral ?g f" + by (simp add: valid_path_join has_contour_integral_integrable) + then show ?thesis + using assms contour_integral_unique by blast +qed lemma has_chain_integral_chain_integral4: - "(f has_contour_integral i) (linepath a b +++ linepath b c +++ linepath c d +++ linepath d e) - \ contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c d) f + contour_integral (linepath d e) f = i" - apply (subst contour_integral_unique [symmetric], assumption) - apply (drule has_contour_integral_integrable) - apply (simp add: valid_path_join) - done + assumes "(f has_contour_integral i) (linepath a b +++ linepath b c +++ linepath c d +++ linepath d e)" + (is "(f has_contour_integral i) ?g") + shows "contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c d) f + contour_integral (linepath d e) f = i" + (is "?lhs = _") +proof - + have "f contour_integrable_on ?g" + using assms contour_integrable_on_def by blast + then have "?lhs = contour_integral ?g f" + by (simp add: valid_path_join has_contour_integral_integrable) + then show ?thesis + using assms contour_integral_unique by blast +qed subsection\<^marker>\tag unimportant\ \The key quadrisection step\ lemma norm_sum_half: assumes "norm(a + b) \ e" shows "norm a \ e/2 \ norm b \ e/2" proof - have "e \ norm (- a - b)" by (simp add: add.commute assms norm_minus_commute) thus ?thesis using norm_triangle_ineq4 order_trans by fastforce qed lemma norm_sum_lemma: assumes "e \ norm (a + b + c + d)" shows "e / 4 \ norm a \ e / 4 \ norm b \ e / 4 \ norm c \ e / 4 \ norm d" proof - have "e \ norm ((a + b) + (c + d))" using assms by (simp add: algebra_simps) then show ?thesis by (auto dest!: norm_sum_half) qed lemma Cauchy_theorem_quadrisection: assumes f: "continuous_on (convex hull {a,b,c}) f" and dist: "dist a b \ K" "dist b c \ K" "dist c a \ K" and e: "e * K^2 \ norm (contour_integral(linepath a b) f + contour_integral(linepath b c) f + contour_integral(linepath c a) f)" shows "\a' b' c'. a' \ convex hull {a,b,c} \ b' \ convex hull {a,b,c} \ c' \ convex hull {a,b,c} \ dist a' b' \ K/2 \ dist b' c' \ K/2 \ dist c' a' \ K/2 \ e * (K/2)^2 \ norm(contour_integral(linepath a' b') f + contour_integral(linepath b' c') f + contour_integral(linepath c' a') f)" (is "\x y z. ?\ x y z") proof - note divide_le_eq_numeral1 [simp del] define a' where "a' = midpoint b c" define b' where "b' = midpoint c a" define c' where "c' = midpoint a b" have fabc: "continuous_on (closed_segment a b) f" "continuous_on (closed_segment b c) f" "continuous_on (closed_segment c a) f" using f continuous_on_subset segments_subset_convex_hull by metis+ have fcont': "continuous_on (closed_segment c' b') f" "continuous_on (closed_segment a' c') f" "continuous_on (closed_segment b' a') f" unfolding a'_def b'_def c'_def by (rule continuous_on_subset [OF f], metis midpoints_in_convex_hull convex_hull_subset hull_subset insert_subset segment_convex_hull)+ - let ?pathint = "\x y. contour_integral(linepath x y) f" - have *: "?pathint a b + ?pathint b c + ?pathint c a = - (?pathint a c' + ?pathint c' b' + ?pathint b' a) + - (?pathint a' c' + ?pathint c' b + ?pathint b a') + - (?pathint a' c + ?pathint c b' + ?pathint b' a') + - (?pathint a' b' + ?pathint b' c' + ?pathint c' a')" + define pathint where "pathint x y \ contour_integral(linepath x y) f" for x y + have *: "pathint a b + pathint b c + pathint c a = + (pathint a c' + pathint c' b' + pathint b' a) + + (pathint a' c' + pathint c' b + pathint b a') + + (pathint a' c + pathint c b' + pathint b' a') + + (pathint a' b' + pathint b' c' + pathint c' a')" + unfolding pathint_def by (simp add: fcont' contour_integral_reverse_linepath) (simp add: a'_def b'_def c'_def contour_integral_midpoint fabc) have [simp]: "\x y. cmod (x * 2 - y * 2) = cmod (x - y) * 2" by (metis left_diff_distrib mult.commute norm_mult_numeral1) have [simp]: "\x y. cmod (x - y) = cmod (y - x)" by (simp add: norm_minus_commute) - consider "e * K\<^sup>2 / 4 \ cmod (?pathint a c' + ?pathint c' b' + ?pathint b' a)" | - "e * K\<^sup>2 / 4 \ cmod (?pathint a' c' + ?pathint c' b + ?pathint b a')" | - "e * K\<^sup>2 / 4 \ cmod (?pathint a' c + ?pathint c b' + ?pathint b' a')" | - "e * K\<^sup>2 / 4 \ cmod (?pathint a' b' + ?pathint b' c' + ?pathint c' a')" - using assms unfolding * by (blast intro: that dest!: norm_sum_lemma) + consider "e * K\<^sup>2 / 4 \ cmod (pathint a c' + pathint c' b' + pathint b' a)" | + "e * K\<^sup>2 / 4 \ cmod (pathint a' c' + pathint c' b + pathint b a')" | + "e * K\<^sup>2 / 4 \ cmod (pathint a' c + pathint c b' + pathint b' a')" | + "e * K\<^sup>2 / 4 \ cmod (pathint a' b' + pathint b' c' + pathint c' a')" + using assms by (metis "*" norm_sum_lemma pathint_def) then show ?thesis proof cases case 1 then have "?\ a c' b'" - using assms + using assms unfolding pathint_def [symmetric] apply (clarsimp simp: c'_def b'_def midpoints_in_convex_hull hull_subset [THEN subsetD]) apply (auto simp: midpoint_def dist_norm scaleR_conv_of_real field_split_simps) done then show ?thesis by blast next case 2 then have "?\ a' c' b" - using assms + using assms unfolding pathint_def [symmetric] apply (clarsimp simp: a'_def c'_def midpoints_in_convex_hull hull_subset [THEN subsetD]) apply (auto simp: midpoint_def dist_norm scaleR_conv_of_real field_split_simps) done then show ?thesis by blast next case 3 then have "?\ a' c b'" - using assms + using assms unfolding pathint_def [symmetric] apply (clarsimp simp: a'_def b'_def midpoints_in_convex_hull hull_subset [THEN subsetD]) apply (auto simp: midpoint_def dist_norm scaleR_conv_of_real field_split_simps) done then show ?thesis by blast next case 4 then have "?\ a' b' c'" - using assms + using assms unfolding pathint_def [symmetric] apply (clarsimp simp: a'_def c'_def b'_def midpoints_in_convex_hull hull_subset [THEN subsetD]) apply (auto simp: midpoint_def dist_norm scaleR_conv_of_real field_split_simps) done then show ?thesis by blast qed qed subsection\<^marker>\tag unimportant\ \Cauchy's theorem for triangles\ lemma triangle_points_closer: fixes a::complex shows "\x \ convex hull {a,b,c}; y \ convex hull {a,b,c}\ \ norm(x - y) \ norm(a - b) \ norm(x - y) \ norm(b - c) \ norm(x - y) \ norm(c - a)" using simplex_extremal_le [of "{a,b,c}"] by (auto simp: norm_minus_commute) + lemma holomorphic_point_small_triangle: assumes x: "x \ S" and f: "continuous_on S f" and cd: "f field_differentiable (at x within S)" and e: "0 < e" shows "\k>0. \a b c. dist a b \ k \ dist b c \ k \ dist c a \ k \ x \ convex hull {a,b,c} \ convex hull {a,b,c} \ S \ norm(contour_integral(linepath a b) f + contour_integral(linepath b c) f + contour_integral(linepath c a) f) \ e*(dist a b + dist b c + dist c a)^2" (is "\k>0. \a b c. _ \ ?normle a b c") proof - have le_of_3: "\a x y z. \0 \ x*y; 0 \ x*z; 0 \ y*z; a \ (e*(x + y + z))*x + (e*(x + y + z))*y + (e*(x + y + z))*z\ \ a \ e*(x + y + z)^2" by (simp add: algebra_simps power2_eq_square) have disj_le: "\x \ a \ x \ b \ x \ c; 0 \ a; 0 \ b; 0 \ c\ \ x \ a + b + c" for x::real and a b c by linarith have fabc: "f contour_integrable_on linepath a b" "f contour_integrable_on linepath b c" "f contour_integrable_on linepath c a" if "convex hull {a, b, c} \ S" for a b c using segments_subset_convex_hull that by (metis continuous_on_subset f contour_integrable_continuous_linepath)+ note path_bound = has_contour_integral_bound_linepath [simplified norm_minus_commute, OF has_contour_integral_integral] { fix f' a b c d assume d: "0 < d" and f': "\y. \cmod (y - x) \ d; y \ S\ \ cmod (f y - f x - f' * (y - x)) \ e * cmod (y - x)" and le: "cmod (a - b) \ d" "cmod (b - c) \ d" "cmod (c - a) \ d" and xc: "x \ convex hull {a, b, c}" and S: "convex hull {a, b, c} \ S" have pa: "contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c a) f = - contour_integral (linepath a b) (\y. f y - f x - f'*(y - x)) + - contour_integral (linepath b c) (\y. f y - f x - f'*(y - x)) + - contour_integral (linepath c a) (\y. f y - f x - f'*(y - x))" + contour_integral (linepath a b) (\y. f y - f x - f' * (y-x)) + + contour_integral (linepath b c) (\y. f y - f x - f' * (y-x)) + + contour_integral (linepath c a) (\y. f y - f x - f' * (y-x))" apply (simp add: contour_integral_diff contour_integral_lmul contour_integrable_lmul contour_integrable_diff fabc [OF S]) apply (simp add: field_simps) done { fix y assume yc: "y \ convex hull {a,b,c}" have "cmod (f y - f x - f' * (y - x)) \ e*norm(y - x)" proof (rule f') show "cmod (y - x) \ d" by (metis triangle_points_closer [OF xc yc] le norm_minus_commute order_trans) qed (use S yc in blast) also have "\ \ e * (cmod (a - b) + cmod (b - c) + cmod (c - a))" by (simp add: yc e xc disj_le [OF triangle_points_closer]) finally have "cmod (f y - f x - f' * (y - x)) \ e * (cmod (a - b) + cmod (b - c) + cmod (c - a))" . } note cm_le = this have "?normle a b c" unfolding dist_norm pa - apply (rule le_of_3) using f' xc S e - apply simp_all - apply (intro norm_triangle_le add_mono path_bound) + apply (intro le_of_3 norm_triangle_le add_mono path_bound) apply (simp_all add: contour_integral_diff contour_integral_lmul contour_integrable_lmul contour_integrable_diff fabc) apply (blast intro: cm_le elim: dest: segments_subset_convex_hull [THEN subsetD])+ done } note * = this show ?thesis using cd e apply (simp add: field_differentiable_def has_field_derivative_def has_derivative_within_alt approachable_lt_le2 Ball_def) apply (clarify dest!: spec mp) using * unfolding dist_norm apply blast done qed text\Hence the most basic theorem for a triangle.\ locale Chain = fixes x0 At Follows assumes At0: "At x0 0" and AtSuc: "\x n. At x n \ \x'. At x' (Suc n) \ Follows x' x" begin primrec f where "f 0 = x0" | "f (Suc n) = (SOME x. At x (Suc n) \ Follows x (f n))" lemma At: "At (f n) n" proof (induct n) case 0 show ?case by (simp add: At0) next case (Suc n) show ?case by (metis (no_types, lifting) AtSuc [OF Suc] f.simps(2) someI_ex) qed lemma Follows: "Follows (f(Suc n)) (f n)" by (metis (no_types, lifting) AtSuc [OF At [of n]] f.simps(2) someI_ex) declare f.simps(2) [simp del] end lemma Chain3: assumes At0: "At x0 y0 z0 0" and AtSuc: "\x y z n. At x y z n \ \x' y' z'. At x' y' z' (Suc n) \ Follows x' y' z' x y z" obtains f g h where "f 0 = x0" "g 0 = y0" "h 0 = z0" "\n. At (f n) (g n) (h n) n" "\n. Follows (f(Suc n)) (g(Suc n)) (h(Suc n)) (f n) (g n) (h n)" proof - interpret three: Chain "(x0,y0,z0)" "\(x,y,z). At x y z" "\(x',y',z'). \(x,y,z). Follows x' y' z' x y z" - apply unfold_locales - using At0 AtSuc by auto + proof qed (use At0 AtSuc in auto) show ?thesis - apply (rule that [of "\n. fst (three.f n)" "\n. fst (snd (three.f n))" "\n. snd (snd (three.f n))"]) - using three.At three.Follows - apply simp_all - apply (simp_all add: split_beta') - done + proof + show "\n. Follows (fst (three.f (Suc n))) (fst (snd (three.f (Suc n)))) + (snd (snd (three.f (Suc n)))) (fst (three.f n)) + (fst (snd (three.f n))) (snd (snd (three.f n)))" + "\n. At (fst (three.f n)) (fst (snd (three.f n))) (snd (snd (three.f n))) n" + using three.At three.Follows + by (simp_all add: split_beta') + qed auto qed + proposition\<^marker>\tag unimportant\ Cauchy_theorem_triangle: assumes "f holomorphic_on (convex hull {a,b,c})" shows "(f has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" proof - have contf: "continuous_on (convex hull {a,b,c}) f" by (metis assms holomorphic_on_imp_continuous_on) let ?pathint = "\x y. contour_integral(linepath x y) f" { fix y::complex assume fy: "(f has_contour_integral y) (linepath a b +++ linepath b c +++ linepath c a)" and ynz: "y \ 0" define K where "K = 1 + max (dist a b) (max (dist b c) (dist c a))" define e where "e = norm y / K^2" have K1: "K \ 1" by (simp add: K_def max.coboundedI1) then have K: "K > 0" by linarith have [iff]: "dist a b \ K" "dist b c \ K" "dist c a \ K" by (simp_all add: K_def) have e: "e > 0" unfolding e_def using ynz K1 by simp define At where "At x y z n \ convex hull {x,y,z} \ convex hull {a,b,c} \ dist x y \ K/2^n \ dist y z \ K/2^n \ dist z x \ K/2^n \ norm(?pathint x y + ?pathint y z + ?pathint z x) \ e*(K/2^n)^2" for x y z n have At0: "At a b c 0" using fy by (simp add: At_def e_def has_chain_integral_chain_integral3) { fix x y z n assume At: "At x y z n" then have contf': "continuous_on (convex hull {x,y,z}) f" using contf At_def continuous_on_subset by metis have "\x' y' z'. At x' y' z' (Suc n) \ convex hull {x',y',z'} \ convex hull {x,y,z}" using At Cauchy_theorem_quadrisection [OF contf', of "K/2^n" e] apply (simp add: At_def algebra_simps) apply (meson convex_hull_subset empty_subsetI insert_subset subsetCE) done } note AtSuc = this obtain fa fb fc where f0 [simp]: "fa 0 = a" "fb 0 = b" "fc 0 = c" and cosb: "\n. convex hull {fa n, fb n, fc n} \ convex hull {a,b,c}" and dist: "\n. dist (fa n) (fb n) \ K/2^n" "\n. dist (fb n) (fc n) \ K/2^n" "\n. dist (fc n) (fa n) \ K/2^n" and no: "\n. norm(?pathint (fa n) (fb n) + ?pathint (fb n) (fc n) + ?pathint (fc n) (fa n)) \ e * (K/2^n)^2" and conv_le: "\n. convex hull {fa(Suc n), fb(Suc n), fc(Suc n)} \ convex hull {fa n, fb n, fc n}" - apply (rule Chain3 [of At, OF At0 AtSuc]) - apply (auto simp: At_def) - done + by (rule Chain3 [of At, OF At0 AtSuc]) (auto simp: At_def) obtain x where x: "\n. x \ convex hull {fa n, fb n, fc n}" proof (rule bounded_closed_nest) show "\n. closed (convex hull {fa n, fb n, fc n})" by (simp add: compact_imp_closed finite_imp_compact_convex_hull) show "\m n. m \ n \ convex hull {fa n, fb n, fc n} \ convex hull {fa m, fb m, fc m}" by (erule transitive_stepwise_le) (auto simp: conv_le) qed (fastforce intro: finite_imp_bounded_convex_hull)+ then have xin: "x \ convex hull {a,b,c}" using assms f0 by blast then have fx: "f field_differentiable at x within (convex hull {a,b,c})" using assms holomorphic_on_def by blast { fix k n assume k: "0 < k" and le: "\x' y' z'. \dist x' y' \ k; dist y' z' \ k; dist z' x' \ k; x \ convex hull {x',y',z'}; convex hull {x',y',z'} \ convex hull {a,b,c}\ \ cmod (?pathint x' y' + ?pathint y' z' + ?pathint z' x') * 10 \ e * (dist x' y' + dist y' z' + dist z' x')\<^sup>2" and Kk: "K / k < 2 ^ n" have "K / 2 ^ n < k" using Kk k by (auto simp: field_simps) then have DD: "dist (fa n) (fb n) \ k" "dist (fb n) (fc n) \ k" "dist (fc n) (fa n) \ k" using dist [of n] k by linarith+ have dle: "(dist (fa n) (fb n) + dist (fb n) (fc n) + dist (fc n) (fa n))\<^sup>2 \ (3 * K / 2 ^ n)\<^sup>2" using dist [of n] e K by (simp add: abs_le_square_iff [symmetric]) have less10: "\x y::real. 0 < x \ y \ 9*x \ y < x*10" by linarith have "e * (dist (fa n) (fb n) + dist (fb n) (fc n) + dist (fc n) (fa n))\<^sup>2 \ e * (3 * K / 2 ^ n)\<^sup>2" using ynz dle e mult_le_cancel_left_pos by blast also have "\ < cmod (?pathint (fa n) (fb n) + ?pathint (fb n) (fc n) + ?pathint (fc n) (fa n)) * 10" using no [of n] e K - apply (simp add: e_def field_simps) - apply (simp only: zero_less_norm_iff [symmetric]) - done + by (simp add: e_def field_simps) (simp only: zero_less_norm_iff [symmetric]) finally have False using le [OF DD x cosb] by auto } then have ?thesis using holomorphic_point_small_triangle [OF xin contf fx, of "e/10"] e apply clarsimp apply (rule_tac y1="K/k" in exE [OF real_arch_pow[of 2]], force+) done } moreover have "f contour_integrable_on (linepath a b +++ linepath b c +++ linepath c a)" by simp (meson contf continuous_on_subset contour_integrable_continuous_linepath segments_subset_convex_hull(1) segments_subset_convex_hull(3) segments_subset_convex_hull(5)) ultimately show ?thesis using has_contour_integral_integral by fastforce qed subsection\<^marker>\tag unimportant\ \Version needing function holomorphic in interior only\ lemma Cauchy_theorem_flat_lemma: assumes f: "continuous_on (convex hull {a,b,c}) f" and c: "c - a = k *\<^sub>R (b - a)" and k: "0 \ k" shows "contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c a) f = 0" proof - have fabc: "continuous_on (closed_segment a b) f" "continuous_on (closed_segment b c) f" "continuous_on (closed_segment c a) f" using f continuous_on_subset segments_subset_convex_hull by metis+ show ?thesis proof (cases "k \ 1") case True show ?thesis by (simp add: contour_integral_split [OF fabc(1) k True c] contour_integral_reverse_linepath fabc) next - case False then show ?thesis - using fabc c - apply (subst contour_integral_split [of a c f "1/k" b, symmetric]) - apply (metis closed_segment_commute fabc(3)) - apply (auto simp: k contour_integral_reverse_linepath) - done + case False + show ?thesis + proof (subst contour_integral_split [symmetric]) + show "b - a = (1/k) *\<^sub>R (c - a)" + using False c by force + show "contour_integral (linepath a c) f + contour_integral (linepath c a) f = 0" + by (simp add: contour_integral_reverse_linepath fabc(3)) + show "continuous_on (closed_segment a c) f" + by (metis closed_segment_commute fabc(3)) + qed (use False in auto) qed qed lemma Cauchy_theorem_flat: assumes f: "continuous_on (convex hull {a,b,c}) f" and c: "c - a = k *\<^sub>R (b - a)" shows "contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c a) f = 0" proof (cases "0 \ k") case True with assms show ?thesis by (blast intro: Cauchy_theorem_flat_lemma) next case False have "continuous_on (closed_segment a b) f" "continuous_on (closed_segment b c) f" "continuous_on (closed_segment c a) f" using f continuous_on_subset segments_subset_convex_hull by metis+ moreover have "contour_integral (linepath b a) f + contour_integral (linepath a c) f + - contour_integral (linepath c b) f = 0" - apply (rule Cauchy_theorem_flat_lemma [of b a c f "1-k"]) - using False c - apply (auto simp: f insert_commute scaleR_conv_of_real algebra_simps) - done + contour_integral (linepath c b) f = 0" + proof (rule Cauchy_theorem_flat_lemma [of b a c f "1-k"]) + show "continuous_on (convex hull {b, a, c}) f" + by (simp add: f insert_commute) + show "c - b = (1 - k) *\<^sub>R (a - b)" + using c by (auto simp: algebra_simps) + qed (use False in auto) ultimately show ?thesis - apply (auto simp: contour_integral_reverse_linepath) - using add_eq_0_iff by force + by (metis (no_types, lifting) contour_integral_reverse_linepath eq_neg_iff_add_eq_0 minus_add_cancel) qed -lemma Cauchy_theorem_triangle_interior: + +proposition Cauchy_theorem_triangle_interior: assumes contf: "continuous_on (convex hull {a,b,c}) f" and holf: "f holomorphic_on interior (convex hull {a,b,c})" shows "(f has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" proof - + define pathint where "pathint \ \x y. contour_integral(linepath x y) f" have fabc: "continuous_on (closed_segment a b) f" "continuous_on (closed_segment b c) f" "continuous_on (closed_segment c a) f" using contf continuous_on_subset segments_subset_convex_hull by metis+ have "bounded (f ` (convex hull {a,b,c}))" by (simp add: compact_continuous_image compact_convex_hull compact_imp_bounded contf) then obtain B where "0 < B" and Bnf: "\x. x \ convex hull {a,b,c} \ norm (f x) \ B" by (auto simp: dest!: bounded_pos [THEN iffD1]) have "bounded (convex hull {a,b,c})" by (simp add: bounded_convex_hull) then obtain C where C: "0 < C" and Cno: "\y. y \ convex hull {a,b,c} \ norm y < C" using bounded_pos_less by blast then have diff_2C: "norm(x - y) \ 2*C" if x: "x \ convex hull {a, b, c}" and y: "y \ convex hull {a, b, c}" for x y proof - have "cmod x \ C" using x by (meson Cno not_le not_less_iff_gr_or_eq) hence "cmod (x - y) \ C + C" using y by (meson Cno add_mono_thms_linordered_field(4) less_eq_real_def norm_triangle_ineq4 order_trans) thus "cmod (x - y) \ 2 * C" by (metis mult_2) qed have contf': "continuous_on (convex hull {b,a,c}) f" using contf by (simp add: insert_commute) { fix y::complex assume fy: "(f has_contour_integral y) (linepath a b +++ linepath b c +++ linepath c a)" and ynz: "y \ 0" - have pi_eq_y: "contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c a) f = y" - by (rule has_chain_integral_chain_integral3 [OF fy]) + have pi_eq_y: "pathint a b + pathint b c + pathint c a= y" + unfolding pathint_def by (rule has_chain_integral_chain_integral3 [OF fy]) have ?thesis proof (cases "c=a \ a=b \ b=c") case True then show ?thesis using Cauchy_theorem_flat [OF contf, of 0] using has_chain_integral_chain_integral3 [OF fy] ynz by (force simp: fabc contour_integral_reverse_linepath) next case False then have car3: "card {a, b, c} = Suc (DIM(complex))" by auto { assume "interior(convex hull {a,b,c}) = {}" then have "collinear{a,b,c}" using interior_convex_hull_eq_empty [OF car3] by (simp add: collinear_3_eq_affine_dependent) with False obtain d where "c \ a" "a \ b" "b \ c" "c - b = d *\<^sub>R (a - b)" by (auto simp: collinear_3 collinear_lemma) then have "False" using False Cauchy_theorem_flat [OF contf'] pi_eq_y ynz - by (simp add: fabc add_eq_0_iff contour_integral_reverse_linepath) + by (simp add: fabc add_eq_0_iff contour_integral_reverse_linepath pathint_def) } then obtain d where d: "d \ interior (convex hull {a, b, c})" by blast { fix d1 assume d1_pos: "0 < d1" and d1: "\x x'. \x\convex hull {a, b, c}; x'\convex hull {a, b, c}; cmod (x' - x) < d1\ \ cmod (f x' - f x) < cmod y / (24 * C)" define e where "e = min 1 (min (d1/(4*C)) ((norm y / 24 / C) / B))" define shrink where "shrink x = x - e *\<^sub>R (x - d)" for x - let ?pathint = "\x y. contour_integral(linepath x y) f" have e: "0 < e" "e \ 1" "e \ d1 / (4 * C)" "e \ cmod y / 24 / C / B" using d1_pos \C>0\ \B>0\ ynz by (simp_all add: e_def) - then have eCB: "24 * e * C * B \ cmod y" - using \C>0\ \B>0\ by (simp add: field_simps) have e_le_d1: "e * (4 * C) \ d1" using e \C>0\ by (simp add: field_simps) have "shrink a \ interior(convex hull {a,b,c})" "shrink b \ interior(convex hull {a,b,c})" "shrink c \ interior(convex hull {a,b,c})" using d e by (auto simp: hull_inc mem_interior_convex_shrink shrink_def) then have fhp0: "(f has_contour_integral 0) (linepath (shrink a) (shrink b) +++ linepath (shrink b) (shrink c) +++ linepath (shrink c) (shrink a))" by (simp add: Cauchy_theorem_triangle holomorphic_on_subset [OF holf] hull_minimal) - then have f_0_shrink: "?pathint (shrink a) (shrink b) + ?pathint (shrink b) (shrink c) + ?pathint (shrink c) (shrink a) = 0" - by (simp add: has_chain_integral_chain_integral3) + then have f_0_shrink: "pathint (shrink a) (shrink b) + pathint (shrink b) (shrink c) + pathint (shrink c) (shrink a) = 0" + by (simp add: has_chain_integral_chain_integral3 pathint_def) have fpi_abc: "f contour_integrable_on linepath (shrink a) (shrink b)" "f contour_integrable_on linepath (shrink b) (shrink c)" "f contour_integrable_on linepath (shrink c) (shrink a)" using fhp0 by (auto simp: valid_path_join dest: has_contour_integral_integrable) have cmod_shr: "\x y. cmod (shrink y - shrink x - (y - x)) = e * cmod (x - y)" using e by (simp add: shrink_def real_vector.scale_right_diff_distrib [symmetric]) have sh_eq: "\a b d::complex. (b - e *\<^sub>R (b - d)) - (a - e *\<^sub>R (a - d)) - (b - a) = e *\<^sub>R (a - b)" by (simp add: algebra_simps) have "cmod y / (24 * C) \ cmod y / cmod (b - a) / 12" using False \C>0\ diff_2C [of b a] ynz by (auto simp: field_split_simps hull_inc) - have less_C: "\u \ convex hull {a, b, c}; 0 \ x; x \ 1\ \ x * cmod u < C" for x u - apply (cases "x=0", simp add: \0) - using Cno [of u] mult_left_le_one_le [of "cmod u" x] le_less_trans norm_ge_zero by blast + have less_C: "x * cmod u < C" if "u \ convex hull {a,b,c}" "0 \ x" "x \ 1" for x u + proof (cases "x=0") + case False + with that show ?thesis + using Cno [of u] mult_left_le_one_le [of "cmod u" x] le_less_trans norm_ge_zero by blast + qed (simp add: \0) { fix u v assume uv: "u \ convex hull {a, b, c}" "v \ convex hull {a, b, c}" "u\v" and fpi_uv: "f contour_integrable_on linepath (shrink u) (shrink v)" have shr_uv: "shrink u \ interior(convex hull {a,b,c})" "shrink v \ interior(convex hull {a,b,c})" using d e uv by (auto simp: hull_inc mem_interior_convex_shrink shrink_def) have cmod_fuv: "\x. 0\x \ x\1 \ cmod (f (linepath (shrink u) (shrink v) x)) \ B" using shr_uv by (blast intro: Bnf linepath_in_convex_hull interior_subset [THEN subsetD]) - have By_uv: "B * (12 * (e * cmod (u - v))) \ cmod y" - apply (rule order_trans [OF _ eCB]) - using e \B>0\ diff_2C [of u v] uv - by (auto simp: field_simps) { fix x::real assume x: "0\x" "x\1" + have "\1 - x\ * cmod u < C" "\x\ * cmod v < C" + using uv x by (auto intro!: less_C) + moreover have "\x\ * cmod d < C" "\1 - x\ * cmod d < C" + using x d interior_subset by (auto intro!: less_C) + ultimately have cmod_less_4C: "cmod ((1 - x) *\<^sub>R u - (1 - x) *\<^sub>R d) + cmod (x *\<^sub>R v - x *\<^sub>R d) < (C+C) + (C+C)" - apply (rule add_strict_mono; rule norm_triangle_half_l [of _ 0]) - using uv x d interior_subset - apply (auto simp: hull_inc intro!: less_C) - done + by (metis add_strict_mono le_less_trans norm_scaleR norm_triangle_ineq4) have ll: "linepath (shrink u) (shrink v) x - linepath u v x = -e * ((1 - x) *\<^sub>R (u - d) + x *\<^sub>R (v - d))" by (simp add: linepath_def shrink_def algebra_simps scaleR_conv_of_real) have cmod_less_dt: "cmod (linepath (shrink u) (shrink v) x - linepath u v x) < d1" - apply (simp only: ll norm_mult scaleR_diff_right) - using \e>0\ cmod_less_4C apply (force intro: norm_triangle_lt less_le_trans [OF _ e_le_d1]) - done - have "cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) < cmod y / (24 * C)" - using x uv shr_uv cmod_less_dt - by (auto simp: hull_inc intro: d1 interior_subset [THEN subsetD] linepath_in_convex_hull) - also have "\ \ cmod y / cmod (v - u) / 12" - using False uv \C>0\ diff_2C [of v u] ynz - by (auto simp: field_split_simps hull_inc) - finally have "cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) \ cmod y / cmod (v - u) / 12" - by simp - then have cmod_12_le: "cmod (v - u) * cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) * 12 \ cmod y" - using uv False by (auto simp: field_simps) + unfolding ll norm_mult scaleR_diff_right + using \e>0\ cmod_less_4C by (force intro: norm_triangle_lt less_le_trans [OF _ e_le_d1]) have "cmod (f (linepath (shrink u) (shrink v) x)) * cmod (shrink v - shrink u - (v - u)) + cmod (v - u) * cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) \ B * (cmod y / 24 / C / B * 2 * C) + 2 * C * (cmod y / 24 / C)" - apply (rule add_mono [OF mult_mono]) - using By_uv e \0 < B\ \0 < C\ x apply (simp_all add: cmod_fuv cmod_shr cmod_12_le) - apply (simp add: field_simps) - done + proof (intro add_mono [OF mult_mono]) + show "cmod (f (linepath (shrink u) (shrink v) x)) \ B" + using cmod_fuv x by blast + have "B * (12 * (e * cmod (u - v))) \ 24 * e * C * B" + using e \B>0\ diff_2C [of u v] uv by (auto simp: field_simps) + also have "\ \ cmod y" + using \C>0\ \B>0\ e by (simp add: field_simps) + finally show "cmod (shrink v - shrink u - (v - u)) \ cmod y / 24 / C / B * 2 * C" + using \0 < B\ \0 < C\ by (simp add: cmod_shr mult_ac divide_simps) + have "cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) < cmod y / (24 * C)" + using x uv shr_uv cmod_less_dt + by (auto simp: hull_inc intro: d1 interior_subset [THEN subsetD] linepath_in_convex_hull) + also have "\ \ cmod y / cmod (v - u) / 12" + using False uv \C>0\ diff_2C [of v u] ynz + by (auto simp: field_split_simps hull_inc) + finally have "cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) \ cmod y / cmod (v - u) / 12" + by simp + then show "cmod (v - u) * cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) + \ 2 * C * (cmod y / 24 / C)" + using uv C by (simp add: field_simps) + qed (use \0 < B\ in auto) also have "\ \ cmod y / 6" by simp finally have "cmod (f (linepath (shrink u) (shrink v) x)) * cmod (shrink v - shrink u - (v - u)) + cmod (v - u) * cmod (f (linepath (shrink u) (shrink v) x) - f (linepath u v x)) \ cmod y / 6" . } note cmod_diff_le = this have f_uv: "continuous_on (closed_segment u v) f" by (blast intro: uv continuous_on_subset [OF contf closed_segment_subset_convex_hull]) - have **: "\f' x' f x::complex. f'*x' - f*x = f'*(x' - x) + x*(f' - f)" + have **: "\f' x' f x::complex. f'*x' - f*x = f' * (x' - x) + x * (f' - f)" by (simp add: algebra_simps) - have "norm (?pathint (shrink u) (shrink v) - ?pathint u v) + have "norm (pathint (shrink u) (shrink v) - pathint u v) \ (B*(norm y /24/C/B)*2*C + (2*C)*(norm y/24/C)) * content (cbox 0 (1::real))" apply (rule has_integral_bound [of _ "\x. f(linepath (shrink u) (shrink v) x) * (shrink v - shrink u) - f(linepath u v x)*(v - u)" _ 0 1]) using ynz \0 < B\ \0 < C\ - apply (simp_all del: le_divide_eq_numeral1) - apply (simp add: has_integral_diff has_contour_integral_linepath [symmetric] has_contour_integral_integral - fpi_uv f_uv contour_integrable_continuous_linepath) + apply (simp_all add: pathint_def has_integral_diff has_contour_integral_linepath [symmetric] has_contour_integral_integral + fpi_uv f_uv contour_integrable_continuous_linepath del: le_divide_eq_numeral1) apply (auto simp: ** norm_triangle_le norm_mult cmod_diff_le simp del: le_divide_eq_numeral1) done also have "\ \ norm y / 6" by simp - finally have "norm (?pathint (shrink u) (shrink v) - ?pathint u v) \ norm y / 6" . + finally have "norm (pathint (shrink u) (shrink v) - pathint u v) \ norm y / 6" . } note * = this - have "norm (?pathint (shrink a) (shrink b) - ?pathint a b) \ norm y / 6" + have "norm (pathint (shrink a) (shrink b) - pathint a b) \ norm y / 6" using False fpi_abc by (rule_tac *) (auto simp: hull_inc) moreover - have "norm (?pathint (shrink b) (shrink c) - ?pathint b c) \ norm y / 6" + have "norm (pathint (shrink b) (shrink c) - pathint b c) \ norm y / 6" using False fpi_abc by (rule_tac *) (auto simp: hull_inc) moreover - have "norm (?pathint (shrink c) (shrink a) - ?pathint c a) \ norm y / 6" + have "norm (pathint (shrink c) (shrink a) - pathint c a) \ norm y / 6" using False fpi_abc by (rule_tac *) (auto simp: hull_inc) ultimately - have "norm((?pathint (shrink a) (shrink b) - ?pathint a b) + - (?pathint (shrink b) (shrink c) - ?pathint b c) + (?pathint (shrink c) (shrink a) - ?pathint c a)) + have "norm((pathint (shrink a) (shrink b) - pathint a b) + + (pathint (shrink b) (shrink c) - pathint b c) + (pathint (shrink c) (shrink a) - pathint c a)) \ norm y / 6 + norm y / 6 + norm y / 6" by (metis norm_triangle_le add_mono) also have "\ = norm y / 2" by simp - finally have "norm((?pathint (shrink a) (shrink b) + ?pathint (shrink b) (shrink c) + ?pathint (shrink c) (shrink a)) - - (?pathint a b + ?pathint b c + ?pathint c a)) + finally have "norm((pathint (shrink a) (shrink b) + pathint (shrink b) (shrink c) + pathint (shrink c) (shrink a)) - + (pathint a b + pathint b c + pathint c a)) \ norm y / 2" by (simp add: algebra_simps) then - have "norm(?pathint a b + ?pathint b c + ?pathint c a) \ norm y / 2" + have "norm(pathint a b + pathint b c + pathint c a) \ norm y / 2" by (simp add: f_0_shrink) (metis (mono_tags) add.commute minus_add_distrib norm_minus_cancel uminus_add_conv_diff) then have "False" using pi_eq_y ynz by auto } note * = this have "uniformly_continuous_on (convex hull {a,b,c}) f" by (simp add: contf compact_convex_hull compact_uniformly_continuous) moreover have "norm y / (24 * C) > 0" using ynz \C > 0\ by auto ultimately obtain \ where "\ > 0" and "\x\convex hull {a, b, c}. \x'\convex hull {a, b, c}. dist x' x < \ \ dist (f x') (f x) < cmod y / (24 * C)" using \C > 0\ ynz unfolding uniformly_continuous_on_def dist_norm by blast hence False using *[of \] by (auto simp: dist_norm) then show ?thesis .. qed } moreover have "f contour_integrable_on (linepath a b +++ linepath b c +++ linepath c a)" using fabc contour_integrable_continuous_linepath by auto ultimately show ?thesis using has_contour_integral_integral by fastforce qed subsection\<^marker>\tag unimportant\ \Version allowing finite number of exceptional points\ proposition\<^marker>\tag unimportant\ Cauchy_theorem_triangle_cofinite: assumes "continuous_on (convex hull {a,b,c}) f" and "finite S" and "(\x. x \ interior(convex hull {a,b,c}) - S \ f field_differentiable (at x))" shows "(f has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" using assms proof (induction "card S" arbitrary: a b c S rule: less_induct) case (less S a b c) show ?case proof (cases "S={}") case True with less show ?thesis by (fastforce simp: holomorphic_on_def field_differentiable_at_within Cauchy_theorem_triangle_interior) next case False then obtain d S' where d: "S = insert d S'" "d \ S'" by (meson Set.set_insert all_not_in_conv) then show ?thesis proof (cases "d \ convex hull {a,b,c}") case False show "(f has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" proof (rule less.hyps) show "\x. x \ interior (convex hull {a, b, c}) - S' \ f field_differentiable at x" using False d interior_subset by (auto intro!: less.prems) qed (use d less.prems in auto) next case True have *: "convex hull {a, b, d} \ convex hull {a, b, c}" by (meson True hull_subset insert_subset convex_hull_subset) have abd: "(f has_contour_integral 0) (linepath a b +++ linepath b d +++ linepath d a)" proof (rule less.hyps) show "\x. x \ interior (convex hull {a, b, d}) - S' \ f field_differentiable at x" using d not_in_interior_convex_hull_3 by (clarsimp intro!: less.prems) (metis * insert_absorb insert_subset interior_mono) qed (use d continuous_on_subset [OF _ *] less.prems in auto) have *: "convex hull {b, c, d} \ convex hull {a, b, c}" by (meson True hull_subset insert_subset convex_hull_subset) have bcd: "(f has_contour_integral 0) (linepath b c +++ linepath c d +++ linepath d b)" proof (rule less.hyps) show "\x. x \ interior (convex hull {b, c, d}) - S' \ f field_differentiable at x" using d not_in_interior_convex_hull_3 by (clarsimp intro!: less.prems) (metis * insert_absorb insert_subset interior_mono) qed (use d continuous_on_subset [OF _ *] less.prems in auto) have *: "convex hull {c, a, d} \ convex hull {a, b, c}" by (meson True hull_subset insert_subset convex_hull_subset) have cad: "(f has_contour_integral 0) (linepath c a +++ linepath a d +++ linepath d c)" proof (rule less.hyps) show "\x. x \ interior (convex hull {c, a, d}) - S' \ f field_differentiable at x" using d not_in_interior_convex_hull_3 by (clarsimp intro!: less.prems) (metis * insert_absorb insert_subset interior_mono) qed (use d continuous_on_subset [OF _ *] less.prems in auto) have "f contour_integrable_on linepath a b" using less.prems abd contour_integrable_joinD1 contour_integrable_on_def by blast moreover have "f contour_integrable_on linepath b c" using less.prems bcd contour_integrable_joinD1 contour_integrable_on_def by blast moreover have "f contour_integrable_on linepath c a" using less.prems cad contour_integrable_joinD1 contour_integrable_on_def by blast ultimately have fpi: "f contour_integrable_on (linepath a b +++ linepath b c +++ linepath c a)" by auto { fix y::complex assume fy: "(f has_contour_integral y) (linepath a b +++ linepath b c +++ linepath c a)" and ynz: "y \ 0" have cont_ad: "continuous_on (closed_segment a d) f" by (meson "*" continuous_on_subset less.prems(1) segments_subset_convex_hull(3)) have cont_bd: "continuous_on (closed_segment b d) f" by (meson True closed_segment_subset_convex_hull continuous_on_subset hull_subset insert_subset less.prems(1)) have cont_cd: "continuous_on (closed_segment c d) f" by (meson "*" continuous_on_subset less.prems(1) segments_subset_convex_hull(2)) have "contour_integral (linepath a b) f = - (contour_integral (linepath b d) f + (contour_integral (linepath d a) f))" "contour_integral (linepath b c) f = - (contour_integral (linepath c d) f + (contour_integral (linepath d b) f))" "contour_integral (linepath c a) f = - (contour_integral (linepath a d) f + contour_integral (linepath d c) f)" using has_chain_integral_chain_integral3 [OF abd] has_chain_integral_chain_integral3 [OF bcd] has_chain_integral_chain_integral3 [OF cad] by (simp_all add: algebra_simps add_eq_0_iff) then have ?thesis using cont_ad cont_bd cont_cd fy has_chain_integral_chain_integral3 contour_integral_reverse_linepath by fastforce } then show ?thesis using fpi contour_integrable_on_def by blast qed qed qed subsection\<^marker>\tag unimportant\ \Cauchy's theorem for an open starlike set\ lemma starlike_convex_subset: assumes S: "a \ S" "closed_segment b c \ S" and subs: "\x. x \ S \ closed_segment a x \ S" - shows "convex hull {a,b,c} \ S" - using S - apply (clarsimp simp add: convex_hull_insert [of "{b,c}" a] segment_convex_hull) - apply (meson subs convexD convex_closed_segment ends_in_segment(1) ends_in_segment(2) subsetCE) - done + shows "convex hull {a,b,c} \ S" +proof - + have "convex hull {b, c} \ S" + using assms(2) segment_convex_hull by auto + then have "\u v d. \0 \ u; 0 \ v; u + v = 1; d \ convex hull {b, c}\ \ u *\<^sub>R a + v *\<^sub>R d \ S" + by (meson subs convexD convex_closed_segment ends_in_segment subsetCE) + then show ?thesis + by (auto simp add: convex_hull_insert [of "{b,c}" a]) +qed lemma triangle_contour_integrals_starlike_primitive: assumes contf: "continuous_on S f" and S: "a \ S" "open S" and x: "x \ S" and subs: "\y. y \ S \ closed_segment a y \ S" and zer: "\b c. closed_segment b c \ S \ contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c a) f = 0" shows "((\x. contour_integral(linepath a x) f) has_field_derivative f x) (at x)" proof - let ?pathint = "\x y. contour_integral(linepath x y) f" { fix e y assume e: "0 < e" and bxe: "ball x e \ S" and close: "cmod (y - x) < e" have y: "y \ S" using bxe close by (force simp: dist_norm norm_minus_commute) have cont_ayf: "continuous_on (closed_segment a y) f" using contf continuous_on_subset subs y by blast have xys: "closed_segment x y \ S" - apply (rule order_trans [OF _ bxe]) - using close - by (auto simp: dist_norm ball_def norm_minus_commute dest: segment_bound) + by (metis bxe centre_in_ball close closed_segment_subset convex_ball dist_norm dual_order.trans e mem_ball norm_minus_commute) have "?pathint a y - ?pathint a x = ?pathint x y" using zer [OF xys] contour_integral_reverse_linepath [OF cont_ayf] add_eq_0_iff by force } note [simp] = this { fix e::real assume e: "0 < e" have cont_atx: "continuous (at x) f" using x S contf continuous_on_eq_continuous_at by blast then obtain d1 where d1: "d1>0" and d1_less: "\y. cmod (y - x) < d1 \ cmod (f y - f x) < e/2" unfolding continuous_at Lim_at dist_norm using e by (drule_tac x="e/2" in spec) force obtain d2 where d2: "d2>0" "ball x d2 \ S" using \open S\ x by (auto simp: open_contains_ball) have dpos: "min d1 d2 > 0" using d1 d2 by simp { fix y assume yx: "y \ x" and close: "cmod (y - x) < min d1 d2" have y: "y \ S" using d2 close by (force simp: dist_norm norm_minus_commute) have "closed_segment x y \ S" using close d2 by (auto simp: dist_norm norm_minus_commute dest!: segment_bound(1)) then have fxy: "f contour_integrable_on linepath x y" by (metis contour_integrable_continuous_linepath continuous_on_subset [OF contf]) then obtain i where i: "(f has_contour_integral i) (linepath x y)" by (auto simp: contour_integrable_on_def) then have "((\w. f w - f x) has_contour_integral (i - f x * (y - x))) (linepath x y)" by (rule has_contour_integral_diff [OF _ has_contour_integral_const_linepath]) then have "cmod (i - f x * (y - x)) \ e / 2 * cmod (y - x)" proof (rule has_contour_integral_bound_linepath) show "\u. u \ closed_segment x y \ cmod (f u - f x) \ e / 2" by (meson close d1_less le_less_trans less_imp_le min.strict_boundedE segment_bound1) qed (use e in simp) also have "\ < e * cmod (y - x)" by (simp add: e yx) finally have "cmod (?pathint x y - f x * (y-x)) / cmod (y-x) < e" using i yx by (simp add: contour_integral_unique divide_less_eq) } then have "\d>0. \y. y \ x \ cmod (y-x) < d \ cmod (?pathint x y - f x * (y-x)) / cmod (y-x) < e" using dpos by blast } - then have *: "(\y. (?pathint x y - f x * (y - x)) /\<^sub>R cmod (y - x)) \x\ 0" + then have "(\y. (?pathint x y - f x * (y - x)) /\<^sub>R cmod (y - x)) \x\ 0" by (simp add: Lim_at dist_norm inverse_eq_divide) - show ?thesis - apply (simp add: has_field_derivative_def has_derivative_at2 bounded_linear_mult_right) - apply (rule Lim_transform [OF * tendsto_eventually]) - using \open S\ x apply (force simp: dist_norm open_contains_ball inverse_eq_divide [symmetric] eventually_at) - done + then have "(\y. (1 / cmod (y - x)) *\<^sub>R (?pathint a y - (?pathint a x + f x * (y - x)))) \x\ 0" + using \open S\ x + by (force simp: dist_norm open_contains_ball inverse_eq_divide [symmetric] eventually_at intro: Lim_transform [OF _ tendsto_eventually]) + then show ?thesis + by (simp add: has_field_derivative_def has_derivative_at2 bounded_linear_mult_right) qed (** Existence of a primitive.*) lemma holomorphic_starlike_primitive: fixes f :: "complex \ complex" assumes contf: "continuous_on S f" and S: "starlike S" and os: "open S" and k: "finite k" and fcd: "\x. x \ S - k \ f field_differentiable at x" shows "\g. \x \ S. (g has_field_derivative f x) (at x)" proof - obtain a where a: "a\S" and a_cs: "\x. x\S \ closed_segment a x \ S" using S by (auto simp: starlike_def) { fix x b c assume "x \ S" "closed_segment b c \ S" then have abcs: "convex hull {a, b, c} \ S" by (simp add: a a_cs starlike_convex_subset) then have "continuous_on (convex hull {a, b, c}) f" by (simp add: continuous_on_subset [OF contf]) then have "(f has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" using abcs interior_subset by (force intro: fcd Cauchy_theorem_triangle_cofinite [OF _ k]) } note 0 = this show ?thesis - apply (intro exI ballI) - apply (rule triangle_contour_integrals_starlike_primitive [OF contf a os], assumption) - apply (metis a_cs) - apply (metis has_chain_integral_chain_integral3 0) - done + proof (intro exI ballI) + show "\x. x \ S \ ((\x. contour_integral (linepath a x) f) has_field_derivative f x) (at x)" + using "0" a a_cs contf has_chain_integral_chain_integral3 os triangle_contour_integrals_starlike_primitive by force + qed qed lemma Cauchy_theorem_starlike: "\open S; starlike S; finite k; continuous_on S f; \x. x \ S - k \ f field_differentiable at x; valid_path g; path_image g \ S; pathfinish g = pathstart g\ \ (f has_contour_integral 0) g" by (metis holomorphic_starlike_primitive Cauchy_theorem_primitive at_within_open) lemma Cauchy_theorem_starlike_simple: "\open S; starlike S; f holomorphic_on S; valid_path g; path_image g \ S; pathfinish g = pathstart g\ \ (f has_contour_integral 0) g" -apply (rule Cauchy_theorem_starlike [OF _ _ finite.emptyI]) -apply (simp_all add: holomorphic_on_imp_continuous_on) -apply (metis at_within_open holomorphic_on_def) -done + using Cauchy_theorem_starlike [OF _ _ finite.emptyI] + by (simp add: holomorphic_on_imp_continuous_on holomorphic_on_imp_differentiable_at) subsection\Cauchy's theorem for a convex set\ text\For a convex set we can avoid assuming openness and boundary analyticity\ lemma triangle_contour_integrals_convex_primitive: assumes contf: "continuous_on S f" and S: "a \ S" "convex S" and x: "x \ S" and zer: "\b c. \b \ S; c \ S\ \ contour_integral (linepath a b) f + contour_integral (linepath b c) f + contour_integral (linepath c a) f = 0" shows "((\x. contour_integral(linepath a x) f) has_field_derivative f x) (at x within S)" proof - let ?pathint = "\x y. contour_integral(linepath x y) f" { fix y assume y: "y \ S" have cont_ayf: "continuous_on (closed_segment a y) f" using S y by (meson contf continuous_on_subset convex_contains_segment) have xys: "closed_segment x y \ S" (*?*) using convex_contains_segment S x y by auto have "?pathint a y - ?pathint a x = ?pathint x y" using zer [OF x y] contour_integral_reverse_linepath [OF cont_ayf] add_eq_0_iff by force } note [simp] = this { fix e::real assume e: "0 < e" have cont_atx: "continuous (at x within S) f" using x S contf by (simp add: continuous_on_eq_continuous_within) then obtain d1 where d1: "d1>0" and d1_less: "\y. \y \ S; cmod (y - x) < d1\ \ cmod (f y - f x) < e/2" unfolding continuous_within Lim_within dist_norm using e by (drule_tac x="e/2" in spec) force { fix y assume yx: "y \ x" and close: "cmod (y - x) < d1" and y: "y \ S" have fxy: "f contour_integrable_on linepath x y" using convex_contains_segment S x y by (blast intro!: contour_integrable_continuous_linepath continuous_on_subset [OF contf]) then obtain i where i: "(f has_contour_integral i) (linepath x y)" by (auto simp: contour_integrable_on_def) then have "((\w. f w - f x) has_contour_integral (i - f x * (y - x))) (linepath x y)" by (rule has_contour_integral_diff [OF _ has_contour_integral_const_linepath]) then have "cmod (i - f x * (y - x)) \ e / 2 * cmod (y - x)" proof (rule has_contour_integral_bound_linepath) show "\u. u \ closed_segment x y \ cmod (f u - f x) \ e / 2" by (meson assms(3) close convex_contains_segment d1_less le_less_trans less_imp_le segment_bound1 subset_iff x y) qed (use e in simp) also have "\ < e * cmod (y - x)" by (simp add: e yx) finally have "cmod (?pathint x y - f x * (y-x)) / cmod (y-x) < e" using i yx by (simp add: contour_integral_unique divide_less_eq) } then have "\d>0. \y\S. y \ x \ cmod (y-x) < d \ cmod (?pathint x y - f x * (y-x)) / cmod (y-x) < e" using d1 by blast } - then have *: "((\y. (contour_integral (linepath x y) f - f x * (y - x)) /\<^sub>R cmod (y - x)) \ 0) (at x within S)" + then have "((\y. (?pathint x y - f x * (y - x)) /\<^sub>R cmod (y - x)) \ 0) (at x within S)" by (simp add: Lim_within dist_norm inverse_eq_divide) - show ?thesis - apply (simp add: has_field_derivative_def has_derivative_within bounded_linear_mult_right) - apply (rule Lim_transform [OF * tendsto_eventually]) + then have "((\y. (1 / cmod (y - x)) *\<^sub>R (?pathint a y - (?pathint a x + f x * (y - x)))) \ 0) + (at x within S)" using linordered_field_no_ub - apply (force simp: inverse_eq_divide [symmetric] eventually_at) - done + by (force simp: inverse_eq_divide [symmetric] eventually_at intro: Lim_transform [OF _ tendsto_eventually]) + then show ?thesis + by (simp add: has_field_derivative_def has_derivative_within bounded_linear_mult_right) qed lemma contour_integral_convex_primitive: assumes "convex S" "continuous_on S f" "\a b c. \a \ S; b \ S; c \ S\ \ (f has_contour_integral 0) (linepath a b +++ linepath b c +++ linepath c a)" obtains g where "\x. x \ S \ (g has_field_derivative f x) (at x within S)" proof (cases "S={}") case False with assms that show ?thesis by (blast intro: triangle_contour_integrals_convex_primitive has_chain_integral_chain_integral3) qed auto lemma holomorphic_convex_primitive: fixes f :: "complex \ complex" assumes "convex S" "finite K" and contf: "continuous_on S f" and fd: "\x. x \ interior S - K \ f field_differentiable at x" obtains g where "\x. x \ S \ (g has_field_derivative f x) (at x within S)" proof (rule contour_integral_convex_primitive [OF \convex S\ contf Cauchy_theorem_triangle_cofinite]) have *: "convex hull {a, b, c} \ S" if "a \ S" "b \ S" "c \ S" for a b c by (simp add: \convex S\ hull_minimal that) show "continuous_on (convex hull {a, b, c}) f" if "a \ S" "b \ S" "c \ S" for a b c by (meson "*" contf continuous_on_subset that) show "f field_differentiable at x" if "a \ S" "b \ S" "c \ S" "x \ interior (convex hull {a, b, c}) - K" for a b c x by (metis "*" DiffD1 DiffD2 DiffI fd interior_mono subsetCE that) qed (use assms in \force+\) lemma holomorphic_convex_primitive': fixes f :: "complex \ complex" assumes "convex S" and "open S" and "f holomorphic_on S" obtains g where "\x. x \ S \ (g has_field_derivative f x) (at x within S)" proof (rule holomorphic_convex_primitive) fix x assume "x \ interior S - {}" with assms show "f field_differentiable at x" by (auto intro!: holomorphic_on_imp_differentiable_at simp: interior_open) qed (use assms in \auto intro: holomorphic_on_imp_continuous_on\) corollary\<^marker>\tag unimportant\ Cauchy_theorem_convex: "\continuous_on S f; convex S; finite K; \x. x \ interior S - K \ f field_differentiable at x; valid_path g; path_image g \ S; pathfinish g = pathstart g\ \ (f has_contour_integral 0) g" by (metis holomorphic_convex_primitive Cauchy_theorem_primitive) corollary Cauchy_theorem_convex_simple: - "\f holomorphic_on S; convex S; - valid_path g; path_image g \ S; - pathfinish g = pathstart g\ \ (f has_contour_integral 0) g" - apply (rule Cauchy_theorem_convex [where K = "{}"]) - apply (simp_all add: holomorphic_on_imp_continuous_on) - using at_within_interior holomorphic_on_def interior_subset by fastforce + assumes holf: "f holomorphic_on S" + and "convex S" "valid_path g" "path_image g \ S" "pathfinish g = pathstart g" + shows "(f has_contour_integral 0) g" +proof - + have "f holomorphic_on interior S" + by (meson holf holomorphic_on_subset interior_subset) + with Cauchy_theorem_convex [where K = "{}"] show ?thesis + using assms + by (metis Diff_empty finite.emptyI holomorphic_on_imp_continuous_on holomorphic_on_imp_differentiable_at open_interior) +qed text\In particular for a disc\ corollary\<^marker>\tag unimportant\ Cauchy_theorem_disc: "\finite K; continuous_on (cball a e) f; \x. x \ ball a e - K \ f field_differentiable at x; valid_path g; path_image g \ cball a e; pathfinish g = pathstart g\ \ (f has_contour_integral 0) g" by (auto intro: Cauchy_theorem_convex) corollary\<^marker>\tag unimportant\ Cauchy_theorem_disc_simple: "\f holomorphic_on (ball a e); valid_path g; path_image g \ ball a e; pathfinish g = pathstart g\ \ (f has_contour_integral 0) g" by (simp add: Cauchy_theorem_convex_simple) subsection\<^marker>\tag unimportant\ \Generalize integrability to local primitives\ lemma contour_integral_local_primitive_lemma: fixes f :: "complex\complex" - shows - "\g piecewise_differentiable_on {a..b}; - \x. x \ s \ (f has_field_derivative f' x) (at x within s); - \x. x \ {a..b} \ g x \ s\ - \ (\x. f' (g x) * vector_derivative g (at x within {a..b})) - integrable_on {a..b}" - apply (cases "cbox a b = {}", force) - apply (simp add: integrable_on_def) - apply (rule exI) - apply (rule contour_integral_primitive_lemma, assumption+) - using atLeastAtMost_iff by blast + assumes gpd: "g piecewise_differentiable_on {a..b}" + and dh: "\x. x \ S \ (f has_field_derivative f' x) (at x within S)" + and gs: "\x. x \ {a..b} \ g x \ S" + shows + "(\x. f' (g x) * vector_derivative g (at x within {a..b})) integrable_on {a..b}" +proof (cases "cbox a b = {}") + case False + then show ?thesis + unfolding integrable_on_def by (auto intro: assms contour_integral_primitive_lemma) +qed auto lemma contour_integral_local_primitive_any: fixes f :: "complex \ complex" assumes gpd: "g piecewise_differentiable_on {a..b}" - and dh: "\x. x \ s + and dh: "\x. x \ S \ \d h. 0 < d \ - (\y. norm(y - x) < d \ (h has_field_derivative f y) (at y within s))" - and gs: "\x. x \ {a..b} \ g x \ s" + (\y. norm(y - x) < d \ (h has_field_derivative f y) (at y within S))" + and gs: "\x. x \ {a..b} \ g x \ S" shows "(\x. f(g x) * vector_derivative g (at x)) integrable_on {a..b}" proof - { fix x assume x: "a \ x" "x \ b" obtain d h where d: "0 < d" - and h: "(\y. norm(y - g x) < d \ (h has_field_derivative f y) (at y within s))" + and h: "(\y. norm(y - g x) < d \ (h has_field_derivative f y) (at y within S))" using x gs dh by (metis atLeastAtMost_iff) have "continuous_on {a..b} g" using gpd piecewise_differentiable_on_def by blast then obtain e where e: "e>0" and lessd: "\x'. x' \ {a..b} \ \x' - x\ < e \ cmod (g x' - g x) < d" - using x d - apply (auto simp: dist_norm continuous_on_iff) - apply (drule_tac x=x in bspec) - using x apply simp - apply (drule_tac x=d in spec, auto) - done - have "\d>0. \u v. u \ x \ x \ v \ {u..v} \ ball x d \ (u \ v \ a \ u \ v \ b) \ + using x d by (fastforce simp: dist_norm continuous_on_iff) + have "\e>0. \u v. u \ x \ x \ v \ {u..v} \ ball x e \ (u \ v \ a \ u \ v \ b) \ (\x. f (g x) * vector_derivative g (at x)) integrable_on {u..v}" - apply (rule_tac x=e in exI) - using e - apply (simp add: integrable_on_localized_vector_derivative [symmetric], clarify) - apply (rule_tac f = h and s = "g ` {u..v}" in contour_integral_local_primitive_lemma) - apply (meson atLeastatMost_subset_iff gpd piecewise_differentiable_on_subset) - apply (force simp: ball_def dist_norm intro: lessd gs DERIV_subset [OF h], force) - done + proof - + have "(\x. f (g x) * vector_derivative g (at x within {u..v})) integrable_on {u..v}" + if "u \ x" "x \ v" and ball: "{u..v} \ ball x e" and auvb: "u \ v \ a \ u \ v \ b" + for u v + proof (rule contour_integral_local_primitive_lemma) + show "g piecewise_differentiable_on {u..v}" + by (metis atLeastatMost_subset_iff gpd piecewise_differentiable_on_subset auvb) + show "\x. x \ g ` {u..v} \ (h has_field_derivative f x) (at x within g ` {u..v})" + using that by (force simp: ball_def dist_norm intro: lessd gs DERIV_subset [OF h]) + qed auto + then show ?thesis + using e integrable_on_localized_vector_derivative by blast + qed } then show ?thesis by (force simp: intro!: integrable_on_little_subintervals [of a b, simplified]) qed lemma contour_integral_local_primitive: fixes f :: "complex \ complex" - assumes g: "valid_path g" "path_image g \ s" - and dh: "\x. x \ s + assumes g: "valid_path g" "path_image g \ S" + and dh: "\x. x \ S \ \d h. 0 < d \ - (\y. norm(y - x) < d \ (h has_field_derivative f y) (at y within s))" - shows "f contour_integrable_on g" - using g - apply (simp add: valid_path_def path_image_def contour_integrable_on_def has_contour_integral_def - has_integral_localized_vector_derivative integrable_on_def [symmetric]) - using contour_integral_local_primitive_any [OF _ dh] - by (meson image_subset_iff piecewise_C1_imp_differentiable) + (\y. norm(y - x) < d \ (h has_field_derivative f y) (at y within S))" + shows "f contour_integrable_on g" +proof - + have "(\x. f (g x) * vector_derivative g (at x)) integrable_on {0..1}" + using contour_integral_local_primitive_any [OF _ dh] g + unfolding path_image_def valid_path_def + by (metis (no_types, lifting) image_subset_iff piecewise_C1_imp_differentiable) + then show ?thesis + using contour_integrable_on by presburger +qed text\In particular if a function is holomorphic\ lemma contour_integrable_holomorphic: - assumes contf: "continuous_on s f" - and os: "open s" + assumes contf: "continuous_on S f" + and os: "open S" and k: "finite k" - and g: "valid_path g" "path_image g \ s" - and fcd: "\x. x \ s - k \ f field_differentiable at x" + and g: "valid_path g" "path_image g \ S" + and fcd: "\x. x \ S - k \ f field_differentiable at x" shows "f contour_integrable_on g" proof - { fix z - assume z: "z \ s" - obtain d where "d>0" and d: "ball z d \ s" using \open s\ z + assume z: "z \ S" + obtain d where "d>0" and d: "ball z d \ S" using \open S\ z by (auto simp: open_contains_ball) then have contfb: "continuous_on (ball z d) f" using contf continuous_on_subset by blast obtain h where "\y\ball z d. (h has_field_derivative f y) (at y within ball z d)" by (metis holomorphic_convex_primitive [OF convex_ball k contfb fcd] d interior_subset Diff_iff subsetD) - then have "\y\ball z d. (h has_field_derivative f y) (at y within s)" + then have "\y\ball z d. (h has_field_derivative f y) (at y within S)" by (metis open_ball at_within_open d os subsetCE) - then have "\h. (\y. cmod (y - z) < d \ (h has_field_derivative f y) (at y within s))" + then have "\h. (\y. cmod (y - z) < d \ (h has_field_derivative f y) (at y within S))" by (force simp: dist_norm norm_minus_commute) - then have "\d h. 0 < d \ (\y. cmod (y - z) < d \ (h has_field_derivative f y) (at y within s))" + then have "\d h. 0 < d \ (\y. cmod (y - z) < d \ (h has_field_derivative f y) (at y within S))" using \0 < d\ by blast } then show ?thesis by (rule contour_integral_local_primitive [OF g]) qed lemma contour_integrable_holomorphic_simple: assumes fh: "f holomorphic_on S" and os: "open S" and g: "valid_path g" "path_image g \ S" shows "f contour_integrable_on g" - apply (rule contour_integrable_holomorphic [OF _ os Finite_Set.finite.emptyI g]) - apply (simp add: fh holomorphic_on_imp_continuous_on) - using fh by (simp add: field_differentiable_def holomorphic_on_open os) +proof - + have "\x. x \ S \ f field_differentiable at x" + using fh holomorphic_on_imp_differentiable_at os by blast + moreover have "continuous_on S f" + by (simp add: fh holomorphic_on_imp_continuous_on) + ultimately show ?thesis + by (metis Diff_empty contour_integrable_holomorphic finite.emptyI g os) +qed lemma continuous_on_inversediff: fixes z:: "'a::real_normed_field" shows "z \ S \ continuous_on S (\w. 1 / (w - z))" by (rule continuous_intros | force)+ lemma contour_integrable_inversediff: - "\valid_path g; z \ path_image g\ \ (\w. 1 / (w-z)) contour_integrable_on g" -apply (rule contour_integrable_holomorphic_simple [of _ "UNIV-{z}"]) -apply (auto simp: holomorphic_on_open open_delete intro!: derivative_eq_intros) -done + assumes g: "valid_path g" + and notin: "z \ path_image g" + shows "(\w. 1 / (w-z)) contour_integrable_on g" +proof (rule contour_integrable_holomorphic_simple) + show "(\w. 1 / (w-z)) holomorphic_on UNIV - {z}" + by (auto simp: holomorphic_on_open open_delete intro!: derivative_eq_intros) +qed (use assms in auto) text\Key fact that path integral is the same for a "nearby" path. This is the main lemma for the homotopy form of Cauchy's theorem and is also useful if we want "without loss of generality" to assume some nice properties of a path (e.g. smoothness). It can also be used to define the integrals of analytic functions over arbitrary continuous paths. This is just done for winding numbers now. \ text\A technical definition to avoid duplication of similar proofs, for paths joined at the ends versus looping paths\ definition linked_paths :: "bool \ (real \ 'a) \ (real \ 'a::topological_space) \ bool" where "linked_paths atends g h == (if atends then pathstart h = pathstart g \ pathfinish h = pathfinish g else pathfinish g = pathstart g \ pathfinish h = pathstart h)" text\This formulation covers two cases: \<^term>\g\ and \<^term>\h\ share their start and end points; \<^term>\g\ and \<^term>\h\ both loop upon themselves.\ lemma contour_integral_nearby: assumes os: "open S" and p: "path p" "path_image p \ S" shows "\d. 0 < d \ (\g h. valid_path g \ valid_path h \ (\t \ {0..1}. norm(g t - p t) < d \ norm(h t - p t) < d) \ linked_paths atends g h \ path_image g \ S \ path_image h \ S \ (\f. f holomorphic_on S \ contour_integral h f = contour_integral g f))" proof - have "\z. \e. z \ path_image p \ 0 < e \ ball z e \ S" using open_contains_ball os p(2) by blast then obtain ee where ee: "\z. z \ path_image p \ 0 < ee z \ ball z (ee z) \ S" by metis define cover where "cover = (\z. ball z (ee z/3)) ` (path_image p)" have "compact (path_image p)" by (metis p(1) compact_path_image) moreover have "path_image p \ (\c\path_image p. ball c (ee c / 3))" using ee by auto ultimately have "\D \ cover. finite D \ path_image p \ \D" by (simp add: compact_eq_Heine_Borel cover_def) then obtain D where D: "D \ cover" "finite D" "path_image p \ \D" by blast then obtain k where k: "k \ {0..1}" "finite k" and D_eq: "D = ((\z. ball z (ee z / 3)) \ p) ` k" - apply (simp add: cover_def path_image_def image_comp) - apply (blast dest!: finite_subset_image [OF \finite D\]) - done + unfolding cover_def path_image_def image_comp + by (meson finite_subset_image) then have kne: "k \ {}" using D by auto have pi: "\i. i \ k \ p i \ path_image p" using k by (auto simp: path_image_def) then have eepi: "\i. i \ k \ 0 < ee((p i))" by (metis ee) define e where "e = Min((ee \ p) ` k)" have fin_eep: "finite ((ee \ p) ` k)" using k by blast have "0 < e" using ee k by (simp add: kne e_def Min_gr_iff [OF fin_eep] eepi) have "uniformly_continuous_on {0..1} p" using p by (simp add: path_def compact_uniformly_continuous) then obtain d::real where d: "d>0" and de: "\x x'. \x' - x\ < d \ x\{0..1} \ x'\{0..1} \ cmod (p x' - p x) < e/3" unfolding uniformly_continuous_on_def dist_norm real_norm_def by (metis divide_pos_pos \0 < e\ zero_less_numeral) then obtain N::nat where N: "N>0" "inverse N < d" using real_arch_inverse [of d] by auto show ?thesis proof (intro exI conjI allI; clarify?) show "e/3 > 0" using \0 < e\ by simp fix g h assume g: "valid_path g" and ghp: "\t\{0..1}. cmod (g t - p t) < e / 3 \ cmod (h t - p t) < e / 3" and h: "valid_path h" and joins: "linked_paths atends g h" { fix t::real assume t: "0 \ t" "t \ 1" then obtain u where u: "u \ k" and ptu: "p t \ ball(p u) (ee(p u) / 3)" using \path_image p \ \D\ D_eq by (force simp: path_image_def) then have ele: "e \ ee (p u)" using fin_eep by (simp add: e_def) have "cmod (g t - p t) < e / 3" "cmod (h t - p t) < e / 3" using ghp t by auto with ele have "cmod (g t - p t) < ee (p u) / 3" "cmod (h t - p t) < ee (p u) / 3" by linarith+ then have "g t \ ball(p u) (ee(p u))" "h t \ ball(p u) (ee(p u))" using norm_diff_triangle_ineq [of "g t" "p t" "p t" "p u"] norm_diff_triangle_ineq [of "h t" "p t" "p t" "p u"] ptu eepi u by (force simp: dist_norm ball_def norm_minus_commute)+ then have "g t \ S" "h t \ S" using ee u k by (auto simp: path_image_def ball_def) } then have ghs: "path_image g \ S" "path_image h \ S" by (auto simp: path_image_def) moreover { fix f assume fhols: "f holomorphic_on S" then have fpa: "f contour_integrable_on g" "f contour_integrable_on h" using g ghs h holomorphic_on_imp_continuous_on os contour_integrable_holomorphic_simple by blast+ have contf: "continuous_on S f" by (simp add: fhols holomorphic_on_imp_continuous_on) { fix z assume z: "z \ path_image p" have "f holomorphic_on ball z (ee z)" using fhols ee z holomorphic_on_subset by blast then have "\ff. (\w \ ball z (ee z). (ff has_field_derivative f w) (at w))" using holomorphic_convex_primitive [of "ball z (ee z)" "{}" f, simplified] by (metis open_ball at_within_open holomorphic_on_def holomorphic_on_imp_continuous_on mem_ball) } then obtain ff where ff: "\z w. \z \ path_image p; w \ ball z (ee z)\ \ (ff z has_field_derivative f w) (at w)" by metis { fix n assume n: "n \ N" then have "contour_integral(subpath 0 (n/N) h) f - contour_integral(subpath 0 (n/N) g) f = contour_integral(linepath (g(n/N)) (h(n/N))) f - contour_integral(linepath (g 0) (h 0)) f" proof (induct n) case 0 show ?case by simp next case (Suc n) obtain t where t: "t \ k" and "p (n/N) \ ball(p t) (ee(p t) / 3)" using \path_image p \ \D\ [THEN subsetD, where c="p (n/N)"] D_eq N Suc.prems by (force simp: path_image_def) then have ptu: "cmod (p t - p (n/N)) < ee (p t) / 3" by (simp add: dist_norm) have e3le: "e/3 \ ee (p t) / 3" using fin_eep t by (simp add: e_def) { fix x assume x: "n/N \ x" "x \ (1 + n)/N" then have nN01: "0 \ n/N" "(1 + n)/N \ 1" using Suc.prems by auto then have x01: "0 \ x" "x \ 1" using x by linarith+ have "cmod (p t - p x) < ee (p t) / 3 + e/3" proof (rule norm_diff_triangle_less [OF ptu de]) show "\real n / real N - x\ < d" using x N by (auto simp: field_simps) qed (use x01 Suc.prems in auto) then have ptx: "cmod (p t - p x) < 2*ee (p t)/3" using e3le eepi [OF t] by simp - have "cmod (p t - g x) < 2*ee (p t)/3 + e/3 " - apply (rule norm_diff_triangle_less [OF ptx]) - using ghp x01 by (simp add: norm_minus_commute) + have "cmod (p t - g x) < 2*ee (p t)/3 + e/3" + using ghp x01 + by (force simp add: norm_minus_commute intro!: norm_diff_triangle_less [OF ptx]) also have "\ \ ee (p t)" using e3le eepi [OF t] by simp finally have gg: "cmod (p t - g x) < ee (p t)" . have "cmod (p t - h x) < 2*ee (p t)/3 + e/3 " - apply (rule norm_diff_triangle_less [OF ptx]) - using ghp x01 by (simp add: norm_minus_commute) + using ghp x01 + by (force simp add: norm_minus_commute intro!: norm_diff_triangle_less [OF ptx]) also have "\ \ ee (p t)" using e3le eepi [OF t] by simp - finally have "cmod (p t - g x) < ee (p t)" - "cmod (p t - h x) < ee (p t)" + finally have "cmod (p t - g x) < ee (p t)" "cmod (p t - h x) < ee (p t)" using gg by auto } note ptgh_ee = this - have "closed_segment (g (real n / real N)) (h (real n / real N)) = path_image (linepath (h (n/N)) (g (n/N)))" + have "closed_segment (g (n/N)) (h (n/N)) = path_image (linepath (h (n/N)) (g (n/N)))" by (simp add: closed_segment_commute) also have pi_hgn: "\ \ ball (p t) (ee (p t))" using ptgh_ee [of "n/N"] Suc.prems by (auto simp: field_simps dist_norm dest: segment_furthest_le [where y="p t"]) finally have gh_ns: "closed_segment (g (n/N)) (h (n/N)) \ S" using ee pi t by blast have pi_ghn': "path_image (linepath (g ((1 + n) / N)) (h ((1 + n) / N))) \ ball (p t) (ee (p t))" using ptgh_ee [of "(1+n)/N"] Suc.prems by (auto simp: field_simps dist_norm dest: segment_furthest_le [where y="p t"]) then have gh_n's: "closed_segment (g ((1 + n) / N)) (h ((1 + n) / N)) \ S" using \N>0\ Suc.prems ee pi t by (auto simp: Path_Connected.path_image_join field_simps) have pi_subset_ball: "path_image (subpath (n/N) ((1+n) / N) g +++ linepath (g ((1+n) / N)) (h ((1+n) / N)) +++ subpath ((1+n) / N) (n/N) h +++ linepath (h (n/N)) (g (n/N))) \ ball (p t) (ee (p t))" - apply (intro subset_path_image_join pi_hgn pi_ghn') - using \N>0\ Suc.prems - apply (auto simp: path_image_subpath dist_norm field_simps closed_segment_eq_real_ivl ptgh_ee) - done + proof (intro subset_path_image_join pi_hgn pi_ghn') + show "path_image (subpath (n/N) ((1+n) / N) g) \ ball (p t) (ee (p t))" + "path_image (subpath ((1+n) / N) (n/N) h) \ ball (p t) (ee (p t))" + using \N>0\ Suc.prems + by (auto simp: path_image_subpath dist_norm field_simps ptgh_ee) + qed have pi0: "(f has_contour_integral 0) (subpath (n/ N) ((Suc n)/N) g +++ linepath(g ((Suc n) / N)) (h((Suc n) / N)) +++ subpath ((Suc n) / N) (n/N) h +++ linepath(h (n/N)) (g (n/N)))" - apply (rule Cauchy_theorem_primitive [of "ball(p t) (ee(p t))" "ff (p t)" "f"]) - apply (metis ff open_ball at_within_open pi t) - using Suc.prems pi_subset_ball apply (simp_all add: valid_path_join valid_path_subpath g h) - done - have fpa1: "f contour_integrable_on subpath (real n / real N) (real (Suc n) / real N) g" + proof (rule Cauchy_theorem_primitive) + show "\x. x \ ball (p t) (ee (p t)) + \ (ff (p t) has_field_derivative f x) (at x within ball (p t) (ee (p t)))" + by (metis ff open_ball at_within_open pi t) + qed (use Suc.prems pi_subset_ball in \simp_all add: valid_path_subpath g h\) + have fpa1: "f contour_integrable_on subpath (n/N) (real (Suc n) / real N) g" using Suc.prems by (simp add: contour_integrable_subpath g fpa) have fpa2: "f contour_integrable_on linepath (g (real (Suc n) / real N)) (h (real (Suc n) / real N))" using gh_n's by (auto intro!: contour_integrable_continuous_linepath continuous_on_subset [OF contf]) - have fpa3: "f contour_integrable_on linepath (h (real n / real N)) (g (real n / real N))" + have fpa3: "f contour_integrable_on linepath (h (n/N)) (g (n/N))" using gh_ns by (auto simp: closed_segment_commute intro!: contour_integrable_continuous_linepath continuous_on_subset [OF contf]) have eq0: "contour_integral (subpath (n/N) ((Suc n) / real N) g) f + contour_integral (linepath (g ((Suc n) / N)) (h ((Suc n) / N))) f + contour_integral (subpath ((Suc n) / N) (n/N) h) f + contour_integral (linepath (h (n/N)) (g (n/N))) f = 0" using contour_integral_unique [OF pi0] Suc.prems by (simp add: g h fpa valid_path_subpath contour_integrable_subpath fpa1 fpa2 fpa3 algebra_simps del: of_nat_Suc) have *: "\hn he hn' gn gd gn' hgn ghn gh0 ghn'. \hn - gn = ghn - gh0; gd + ghn' + he + hgn = (0::complex); hn - he = hn'; gn + gd = gn'; hgn = -ghn\ \ hn' - gn' = ghn' - gh0" by (auto simp: algebra_simps) have "contour_integral (subpath 0 (n/N) h) f - contour_integral (subpath ((Suc n) / N) (n/N) h) f = contour_integral (subpath 0 (n/N) h) f + contour_integral (subpath (n/N) ((Suc n) / N) h) f" unfolding reversepath_subpath [symmetric, of "((Suc n) / N)"] using Suc.prems by (simp add: h fpa contour_integral_reversepath valid_path_subpath contour_integrable_subpath) also have "\ = contour_integral (subpath 0 ((Suc n) / N) h) f" using Suc.prems by (simp add: contour_integral_subpath_combine h fpa) finally have pi0_eq: "contour_integral (subpath 0 (n/N) h) f - contour_integral (subpath ((Suc n) / N) (n/N) h) f = contour_integral (subpath 0 ((Suc n) / N) h) f" . show ?case - apply (rule * [OF Suc.hyps eq0 pi0_eq]) - using Suc.prems - apply (simp_all add: g h fpa contour_integral_subpath_combine - contour_integral_reversepath [symmetric] contour_integrable_continuous_linepath - continuous_on_subset [OF contf gh_ns]) - done + proof (rule * [OF Suc.hyps eq0 pi0_eq]) + show "contour_integral (subpath 0 (n/N) g) f + + contour_integral (subpath (n/N) ((Suc n) / N) g) f = + contour_integral (subpath 0 ((Suc n) / N) g) f" + using Suc.prems contour_integral_subpath_combine fpa(1) g by auto + show "contour_integral (linepath (h (n/N)) (g (n/N))) f = - contour_integral (linepath (g (n/N)) (h (n/N))) f" + by (metis contour_integral_unique fpa3 has_contour_integral_integral has_contour_integral_reverse_linepath) + qed (use Suc.prems in auto) qed } note ind = this have "contour_integral h f = contour_integral g f" using ind [OF order_refl] N joins by (simp add: linked_paths_def pathstart_def pathfinish_def split: if_split_asm) } ultimately show "path_image g \ S \ path_image h \ S \ (\f. f holomorphic_on S \ contour_integral h f = contour_integral g f)" by metis qed qed lemma assumes "open S" "path p" "path_image p \ S" shows contour_integral_nearby_ends: "\d. 0 < d \ (\g h. valid_path g \ valid_path h \ (\t \ {0..1}. norm(g t - p t) < d \ norm(h t - p t) < d) \ pathstart h = pathstart g \ pathfinish h = pathfinish g \ path_image g \ S \ path_image h \ S \ (\f. f holomorphic_on S \ contour_integral h f = contour_integral g f))" and contour_integral_nearby_loops: "\d. 0 < d \ (\g h. valid_path g \ valid_path h \ (\t \ {0..1}. norm(g t - p t) < d \ norm(h t - p t) < d) \ pathfinish g = pathstart g \ pathfinish h = pathstart h \ path_image g \ S \ path_image h \ S \ (\f. f holomorphic_on S \ contour_integral h f = contour_integral g f))" using contour_integral_nearby [OF assms, where atends=True] using contour_integral_nearby [OF assms, where atends=False] unfolding linked_paths_def by simp_all lemma contour_integral_bound_exists: assumes S: "open S" and g: "valid_path g" and pag: "path_image g \ S" shows "\L. 0 < L \ (\f B. f holomorphic_on S \ (\z \ S. norm(f z) \ B) \ norm(contour_integral g f) \ L*B)" proof - have "path g" using g by (simp add: valid_path_imp_path) then obtain d::real and p where d: "0 < d" and p: "polynomial_function p" "path_image p \ S" and pi: "\f. f holomorphic_on S \ contour_integral g f = contour_integral p f" using contour_integral_nearby_ends [OF S \path g\ pag] by (metis cancel_comm_monoid_add_class.diff_cancel g norm_zero path_approx_polynomial_function valid_path_polynomial_function) then obtain p' where p': "polynomial_function p'" "\x. (p has_vector_derivative (p' x)) (at x)" by (blast intro: has_vector_derivative_polynomial_function that) then have "bounded(p' ` {0..1})" using continuous_on_polymonial_function by (force simp: intro!: compact_imp_bounded compact_continuous_image) then obtain L where L: "L>0" and nop': "\x. \0 \ x; x \ 1\ \ norm (p' x) \ L" by (force simp: bounded_pos) { fix f B assume f: "f holomorphic_on S" and B: "\z. z\S \ cmod (f z) \ B" then have "f contour_integrable_on p \ valid_path p" using p S by (blast intro: valid_path_polynomial_function contour_integrable_holomorphic_simple holomorphic_on_imp_continuous_on) moreover have "cmod (vector_derivative p (at x)) * cmod (f (p x)) \ L * B" if "0 \ x" "x \ 1" for x proof (rule mult_mono) show "cmod (vector_derivative p (at x)) \ L" by (metis nop' p'(2) that vector_derivative_at) show "cmod (f (p x)) \ B" by (metis B atLeastAtMost_iff imageI p(2) path_defs(4) subset_eq that) qed (use \L>0\ in auto) - ultimately have "cmod (contour_integral g f) \ L * B" - apply (simp only: pi [OF f]) - apply (simp only: contour_integral_integral) - apply (rule order_trans [OF integral_norm_bound_integral]) - apply (auto simp: mult.commute integral_norm_bound_integral contour_integrable_on [symmetric] norm_mult) - done + ultimately + have "cmod (integral {0..1} (\x. f (p x) * vector_derivative p (at x))) \ L * B" + by (intro order_trans [OF integral_norm_bound_integral]) + (auto simp: mult.commute norm_mult contour_integrable_on) + then have "cmod (contour_integral g f) \ L * B" + using contour_integral_integral f pi by presburger } then show ?thesis using \L > 0\ by (intro exI[of _ L]) auto qed subsection\Homotopy forms of Cauchy's theorem\ lemma Cauchy_theorem_homotopic: - assumes hom: "if atends then homotopic_paths s g h else homotopic_loops s g h" - and "open s" and f: "f holomorphic_on s" + assumes hom: "if atends then homotopic_paths S g h else homotopic_loops S g h" + and "open S" and f: "f holomorphic_on S" and vpg: "valid_path g" and vph: "valid_path h" shows "contour_integral g f = contour_integral h f" proof - have pathsf: "linked_paths atends g h" using hom by (auto simp: linked_paths_def homotopic_paths_imp_pathstart homotopic_paths_imp_pathfinish homotopic_loops_imp_loop) obtain k :: "real \ real \ complex" where contk: "continuous_on ({0..1} \ {0..1}) k" - and ks: "k ` ({0..1} \ {0..1}) \ s" + and ks: "k ` ({0..1} \ {0..1}) \ S" and k [simp]: "\x. k (0, x) = g x" "\x. k (1, x) = h x" and ksf: "\t\{0..1}. linked_paths atends g (\x. k (t, x))" using hom pathsf by (auto simp: linked_paths_def homotopic_paths_def homotopic_loops_def homotopic_with_def split: if_split_asm) have ucontk: "uniformly_continuous_on ({0..1} \ {0..1}) k" by (blast intro: compact_Times compact_uniformly_continuous [OF contk]) { fix t::real assume t: "t \ {0..1}" - have pak: "path (k \ (\u. (t, u)))" + have "Pair t ` {0..1} \ {0..1} \ {0..1}" + using t by force + then have pak: "path (k \ (\u. (t, u)))" unfolding path_def - apply (rule continuous_intros continuous_on_subset [OF contk])+ - using t by force - have pik: "path_image (k \ Pair t) \ s" + by (intro continuous_intros continuous_on_subset [OF contk])+ + have pik: "path_image (k \ Pair t) \ S" using ks t by (auto simp: path_image_def) obtain e where "e>0" and e: "\g h. \valid_path g; valid_path h; \u\{0..1}. cmod (g u - (k \ Pair t) u) < e \ cmod (h u - (k \ Pair t) u) < e; linked_paths atends g h\ \ contour_integral h f = contour_integral g f" - using contour_integral_nearby [OF \open s\ pak pik, of atends] f by metis + using contour_integral_nearby [OF \open S\ pak pik, of atends] f by metis obtain d where "d>0" and d: "\x x'. \x \ {0..1} \ {0..1}; x' \ {0..1} \ {0..1}; norm (x'-x) < d\ \ norm (k x' - k x) < e/4" by (rule uniformly_continuous_onE [OF ucontk, of "e/4"]) (auto simp: dist_norm \e>0\) { fix t1 t2 assume t1: "0 \ t1" "t1 \ 1" and t2: "0 \ t2" "t2 \ 1" and ltd: "\t1 - t\ < d" "\t2 - t\ < d" - have no2: "\g1 k1 kt. \norm(g1 - k1) < e/4; norm(k1 - kt) < e/4\ \ norm(g1 - kt) < e" - using \e > 0\ - apply (rule_tac y = k1 in norm_triangle_half_l) - apply (auto simp: norm_minus_commute intro: order_less_trans) - done + have no2: "norm(g1 - kt) < e" if "norm(g1 - k1) < e/4" "norm(k1 - kt) < e/4" for g1 k1 kt :: complex + proof (rule norm_triangle_half_l) + show "cmod (g1 - k1) < e/2" "cmod (kt - k1) < e/2" + using \e > 0\ that by (auto simp: norm_minus_commute intro: order_less_trans) + qed have "\d>0. \g1 g2. valid_path g1 \ valid_path g2 \ (\u\{0..1}. cmod (g1 u - k (t1, u)) < d \ cmod (g2 u - k (t2, u)) < d) \ linked_paths atends g1 g2 \ contour_integral g2 f = contour_integral g1 f" - apply (rule_tac x="e/4" in exI) using t t1 t2 ltd \e > 0\ - apply (auto intro!: e simp: d no2 simp del: less_divide_eq_numeral1) - done + by (rule_tac x="e/4" in exI) (auto intro!: e simp: d no2 simp del: less_divide_eq_numeral1) } then have "\e. 0 < e \ (\t1 t2. t1 \ {0..1} \ t2 \ {0..1} \ \t1 - t\ < e \ \t2 - t\ < e \ (\d. 0 < d \ (\g1 g2. valid_path g1 \ valid_path g2 \ (\u \ {0..1}. norm(g1 u - k((t1,u))) < d \ norm(g2 u - k((t2,u))) < d) \ linked_paths atends g1 g2 \ contour_integral g2 f = contour_integral g1 f)))" by (rule_tac x=d in exI) (simp add: \d > 0\) } then obtain ee where ee: "\t. t \ {0..1} \ ee t > 0 \ (\t1 t2. t1 \ {0..1} \ t2 \ {0..1} \ \t1 - t\ < ee t \ \t2 - t\ < ee t \ (\d. 0 < d \ (\g1 g2. valid_path g1 \ valid_path g2 \ (\u \ {0..1}. norm(g1 u - k((t1,u))) < d \ norm(g2 u - k((t2,u))) < d) \ linked_paths atends g1 g2 \ contour_integral g2 f = contour_integral g1 f)))" by metis - note ee_rule = ee [THEN conjunct2, rule_format] + note ee_rule = ee [THEN conjunct2, rule_format, of 0 0 0] define C where "C = (\t. ball t (ee t / 3)) ` {0..1}" obtain C' where C': "C' \ C" "finite C'" and C'01: "{0..1} \ \C'" proof (rule compactE [OF compact_interval]) show "{0..1} \ \C" using ee [THEN conjunct1] by (auto simp: C_def dist_norm) qed (use C_def in auto) define kk where "kk = {t \ {0..1}. ball t (ee t / 3) \ C'}" have kk01: "kk \ {0..1}" by (auto simp: kk_def) define e where "e = Min (ee ` kk)" have C'_eq: "C' = (\t. ball t (ee t / 3)) ` kk" using C' by (auto simp: kk_def C_def) have ee_pos[simp]: "\t. t \ {0..1} \ ee t > 0" by (simp add: kk_def ee) moreover have "finite kk" using \finite C'\ kk01 by (force simp: C'_eq inj_on_def ball_eq_ball_iff dest: ee_pos finite_imageD) moreover have "kk \ {}" using \{0..1} \ \C'\ C'_eq by force ultimately have "e > 0" using finite_less_Inf_iff [of "ee ` kk" 0] kk01 by (force simp: e_def) then obtain N::nat where "N > 0" and N: "1/N < e/3" by (meson divide_pos_pos nat_approx_posE zero_less_Suc zero_less_numeral) have e_le_ee: "\i. i \ kk \ e \ ee i" using \finite kk\ by (simp add: e_def Min_le_iff [of "ee ` kk"]) have plus: "\t \ kk. x \ ball t (ee t / 3)" if "x \ {0..1}" for x using C' subsetD [OF C'01 that] unfolding C'_eq by blast have [OF order_refl]: "\d. 0 < d \ (\j. valid_path j \ (\u \ {0..1}. norm(j u - k (n/N, u)) < d) \ linked_paths atends g j \ contour_integral j f = contour_integral g f)" if "n \ N" for n using that proof (induct n) - case 0 show ?case using ee_rule [of 0 0 0] - apply clarsimp - apply (rule_tac x=d in exI, safe) - by (metis diff_self vpg norm_zero) + case 0 show ?case + using ee_rule + by clarsimp (metis diff_self norm_eq_zero vpg) next case (Suc n) then have N01: "n/N \ {0..1}" "(Suc n)/N \ {0..1}" by auto then obtain t where t: "t \ kk" "n/N \ ball t (ee t / 3)" using plus [of "n/N"] by blast then have nN_less: "\n/N - t\ < ee t" by (simp add: dist_norm del: less_divide_eq_numeral1) have n'N_less: "\real (Suc n) / real N - t\ < ee t" using t N \N > 0\ e_le_ee [of t] by (simp add: dist_norm add_divide_distrib abs_diff_less_iff del: less_divide_eq_numeral1) (simp add: field_simps) have t01: "t \ {0..1}" using \kk \ {0..1}\ \t \ kk\ by blast obtain d1 where "d1 > 0" and d1: "\g1 g2. \valid_path g1; valid_path g2; \u\{0..1}. cmod (g1 u - k (n/N, u)) < d1 \ cmod (g2 u - k ((Suc n) / N, u)) < d1; linked_paths atends g1 g2\ \ contour_integral g2 f = contour_integral g1 f" using ee [THEN conjunct2, rule_format, OF t01 N01 nN_less n'N_less] by fastforce have "n \ N" using Suc.prems by auto with Suc.hyps obtain d2 where "d2 > 0" and d2: "\j. \valid_path j; \u\{0..1}. cmod (j u - k (n/N, u)) < d2; linked_paths atends g j\ \ contour_integral j f = contour_integral g f" - by auto - have "continuous_on {0..1} (k \ (\u. (n/N, u)))" - apply (rule continuous_intros continuous_on_subset [OF contk])+ + by auto + have "Pair (n/ N) ` {0..1} \ {0..1} \ {0..1}" using N01 by auto + then have "continuous_on {0..1} (k \ (\u. (n/N, u)))" + by (intro continuous_intros continuous_on_subset [OF contk]) then have pkn: "path (\u. k (n/N, u))" by (simp add: path_def) have min12: "min d1 d2 > 0" by (simp add: \0 < d1\ \0 < d2\) obtain p where "polynomial_function p" and psf: "pathstart p = pathstart (\u. k (n/N, u))" "pathfinish p = pathfinish (\u. k (n/N, u))" and pk_le: "\t. t\{0..1} \ cmod (p t - k (n/N, t)) < min d1 d2" using path_approx_polynomial_function [OF pkn min12] by blast then have vpp: "valid_path p" using valid_path_polynomial_function by blast have lpa: "linked_paths atends g p" by (metis (mono_tags, lifting) N01(1) ksf linked_paths_def pathfinish_def pathstart_def psf) show ?case proof (intro exI; safe) fix j assume "valid_path j" "linked_paths atends g j" and "\u\{0..1}. cmod (j u - k (real (Suc n) / real N, u)) < min d1 d2" then have "contour_integral j f = contour_integral p f" using pk_le N01(1) ksf by (force intro!: vpp d1 simp add: linked_paths_def psf) also have "... = contour_integral g f" using pk_le by (force intro!: vpp d2 lpa) finally show "contour_integral j f = contour_integral g f" . qed (simp add: \0 < d1\ \0 < d2\) qed then obtain d where "0 < d" "\j. valid_path j \ (\u \ {0..1}. norm(j u - k (1,u)) < d) \ linked_paths atends g j \ contour_integral j f = contour_integral g f" using \N>0\ by auto then have "linked_paths atends g h \ contour_integral h f = contour_integral g f" using \N>0\ vph by fastforce then show ?thesis by (simp add: pathsf) qed proposition Cauchy_theorem_homotopic_paths: - assumes hom: "homotopic_paths s g h" - and "open s" and f: "f holomorphic_on s" + assumes hom: "homotopic_paths S g h" + and "open S" and f: "f holomorphic_on S" and vpg: "valid_path g" and vph: "valid_path h" shows "contour_integral g f = contour_integral h f" - using Cauchy_theorem_homotopic [of True s g h] assms by simp + using Cauchy_theorem_homotopic [of True S g h] assms by simp proposition Cauchy_theorem_homotopic_loops: - assumes hom: "homotopic_loops s g h" - and "open s" and f: "f holomorphic_on s" + assumes hom: "homotopic_loops S g h" + and "open S" and f: "f holomorphic_on S" and vpg: "valid_path g" and vph: "valid_path h" shows "contour_integral g f = contour_integral h f" - using Cauchy_theorem_homotopic [of False s g h] assms by simp + using Cauchy_theorem_homotopic [of False S g h] assms by simp lemma has_contour_integral_newpath: "\(f has_contour_integral y) h; f contour_integrable_on g; contour_integral g f = contour_integral h f\ \ (f has_contour_integral y) g" using has_contour_integral_integral contour_integral_unique by auto lemma Cauchy_theorem_null_homotopic: - "\f holomorphic_on s; open s; valid_path g; homotopic_loops s g (linepath a a)\ \ (f has_contour_integral 0) g" - apply (rule has_contour_integral_newpath [where h = "linepath a a"], simp) - using contour_integrable_holomorphic_simple - apply (blast dest: holomorphic_on_imp_continuous_on homotopic_loops_imp_subset) - by (simp add: Cauchy_theorem_homotopic_loops) + "\f holomorphic_on S; open S; valid_path g; homotopic_loops S g (linepath a a)\ + \ (f has_contour_integral 0) g" + by (metis Cauchy_theorem_homotopic_loops contour_integrable_holomorphic_simple valid_path_linepath + contour_integral_trivial has_contour_integral_integral homotopic_loops_imp_subset) end \ No newline at end of file diff --git a/src/HOL/Homology/Brouwer_Degree.thy b/src/HOL/Homology/Brouwer_Degree.thy --- a/src/HOL/Homology/Brouwer_Degree.thy +++ b/src/HOL/Homology/Brouwer_Degree.thy @@ -1,1682 +1,1682 @@ section\Homology, III: Brouwer Degree\ theory Brouwer_Degree - imports Homology_Groups + imports Homology_Groups "HOL-Algebra.Multiplicative_Group" begin subsection\Reduced Homology\ definition reduced_homology_group :: "int \ 'a topology \ 'a chain set monoid" where "reduced_homology_group p X \ subgroup_generated (homology_group p X) (kernel (homology_group p X) (homology_group p (discrete_topology {()})) (hom_induced p X {} (discrete_topology {()}) {} (\x. ())))" lemma one_reduced_homology_group: "\\<^bsub>reduced_homology_group p X\<^esub> = \\<^bsub>homology_group p X\<^esub>" by (simp add: reduced_homology_group_def) lemma group_reduced_homology_group [simp]: "group (reduced_homology_group p X)" by (simp add: reduced_homology_group_def group.group_subgroup_generated) lemma carrier_reduced_homology_group: "carrier (reduced_homology_group p X) = kernel (homology_group p X) (homology_group p (discrete_topology {()})) (hom_induced p X {} (discrete_topology {()}) {} (\x. ()))" (is "_ = kernel ?G ?H ?h") proof - interpret subgroup "kernel ?G ?H ?h" ?G by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def group_hom.subgroup_kernel) show ?thesis unfolding reduced_homology_group_def using carrier_subgroup_generated_subgroup by blast qed lemma carrier_reduced_homology_group_subset: "carrier (reduced_homology_group p X) \ carrier (homology_group p X)" by (simp add: group.carrier_subgroup_generated_subset reduced_homology_group_def) lemma un_reduced_homology_group: assumes "p \ 0" shows "reduced_homology_group p X = homology_group p X" proof - have "(kernel (homology_group p X) (homology_group p (discrete_topology {()})) (hom_induced p X {} (discrete_topology {()}) {} (\x. ()))) = carrier (homology_group p X)" proof (rule group_hom.kernel_to_trivial_group) show "group_hom (homology_group p X) (homology_group p (discrete_topology {()})) (hom_induced p X {} (discrete_topology {()}) {} (\x. ()))" by (auto simp: hom_induced_empty_hom group_hom_def group_hom_axioms_def) show "trivial_group (homology_group p (discrete_topology {()}))" by (simp add: homology_dimension_axiom [OF _ assms]) qed then show ?thesis by (simp add: reduced_homology_group_def group.subgroup_generated_group_carrier) qed lemma trivial_reduced_homology_group: "p < 0 \ trivial_group(reduced_homology_group p X)" by (simp add: trivial_homology_group un_reduced_homology_group) lemma hom_induced_reduced_hom: "(hom_induced p X {} Y {} f) \ hom (reduced_homology_group p X) (reduced_homology_group p Y)" proof (cases "continuous_map X Y f") case True have eq: "continuous_map X Y f \ hom_induced p X {} (discrete_topology {()}) {} (\x. ()) = (hom_induced p Y {} (discrete_topology {()}) {} (\x. ()) \ hom_induced p X {} Y {} f)" by (simp flip: hom_induced_compose_empty) interpret subgroup "kernel (homology_group p X) (homology_group p (discrete_topology {()})) (hom_induced p X {} (discrete_topology {()}) {} (\x. ()))" "homology_group p X" by (meson group_hom.subgroup_kernel group_hom_axioms_def group_hom_def group_relative_homology_group hom_induced) have sb: "hom_induced p X {} Y {} f ` carrier (homology_group p X) \ carrier (homology_group p Y)" using hom_induced_carrier by blast show ?thesis using True unfolding reduced_homology_group_def apply (simp add: hom_into_subgroup_eq group_hom.subgroup_kernel hom_induced_empty_hom group.hom_from_subgroup_generated group_hom_def group_hom_axioms_def) unfolding kernel_def using eq sb by auto next case False then have "hom_induced p X {} Y {} f = (\c. one(reduced_homology_group p Y))" by (force simp: hom_induced_default reduced_homology_group_def) then show ?thesis by (simp add: trivial_hom) qed lemma hom_induced_reduced: "c \ carrier(reduced_homology_group p X) \ hom_induced p X {} Y {} f c \ carrier(reduced_homology_group p Y)" by (meson hom_in_carrier hom_induced_reduced_hom) lemma hom_boundary_reduced_hom: "hom_boundary p X S \ hom (relative_homology_group p X S) (reduced_homology_group (p-1) (subtopology X S))" proof - have *: "continuous_map X (discrete_topology {()}) (\x. ())" "(\x. ()) ` S \ {()}" by auto interpret group_hom "relative_homology_group p (discrete_topology {()}) {()}" "homology_group (p-1) (discrete_topology {()})" "hom_boundary p (discrete_topology {()}) {()}" apply (clarsimp simp: group_hom_def group_hom_axioms_def) by (metis UNIV_unit hom_boundary_hom subtopology_UNIV) have "hom_boundary p X S ` carrier (relative_homology_group p X S) \ kernel (homology_group (p - 1) (subtopology X S)) (homology_group (p - 1) (discrete_topology {()})) (hom_induced (p - 1) (subtopology X S) {} (discrete_topology {()}) {} (\x. ()))" proof (clarsimp simp add: kernel_def hom_boundary_carrier) fix c assume c: "c \ carrier (relative_homology_group p X S)" have triv: "trivial_group (relative_homology_group p (discrete_topology {()}) {()})" by (metis topspace_discrete_topology trivial_relative_homology_group_topspace) have "hom_boundary p (discrete_topology {()}) {()} (hom_induced p X S (discrete_topology {()}) {()} (\x. ()) c) = \\<^bsub>homology_group (p - 1) (discrete_topology {()})\<^esub>" by (metis hom_induced_carrier local.hom_one singletonD triv trivial_group_def) then show "hom_induced (p - 1) (subtopology X S) {} (discrete_topology {()}) {} (\x. ()) (hom_boundary p X S c) = \\<^bsub>homology_group (p - 1) (discrete_topology {()})\<^esub>" using naturality_hom_induced [OF *, of p, symmetric] by (simp add: o_def fun_eq_iff) qed then show ?thesis by (simp add: reduced_homology_group_def hom_boundary_hom hom_into_subgroup) qed lemma homotopy_equivalence_reduced_homology_group_isomorphisms: assumes contf: "continuous_map X Y f" and contg: "continuous_map Y X g" and gf: "homotopic_with (\h. True) X X (g \ f) id" and fg: "homotopic_with (\k. True) Y Y (f \ g) id" shows "group_isomorphisms (reduced_homology_group p X) (reduced_homology_group p Y) (hom_induced p X {} Y {} f) (hom_induced p Y {} X {} g)" proof (simp add: hom_induced_reduced_hom group_isomorphisms_def, intro conjI ballI) fix a assume "a \ carrier (reduced_homology_group p X)" then have "(hom_induced p Y {} X {} g \ hom_induced p X {} Y {} f) a = a" apply (simp add: contf contg flip: hom_induced_compose) using carrier_reduced_homology_group_subset gf hom_induced_id homology_homotopy_empty by fastforce then show "hom_induced p Y {} X {} g (hom_induced p X {} Y {} f a) = a" by simp next fix b assume "b \ carrier (reduced_homology_group p Y)" then have "(hom_induced p X {} Y {} f \ hom_induced p Y {} X {} g) b = b" apply (simp add: contf contg flip: hom_induced_compose) using carrier_reduced_homology_group_subset fg hom_induced_id homology_homotopy_empty by fastforce then show "hom_induced p X {} Y {} f (hom_induced p Y {} X {} g b) = b" by (simp add: carrier_reduced_homology_group) qed lemma homotopy_equivalence_reduced_homology_group_isomorphism: assumes "continuous_map X Y f" "continuous_map Y X g" and "homotopic_with (\h. True) X X (g \ f) id" "homotopic_with (\k. True) Y Y (f \ g) id" shows "(hom_induced p X {} Y {} f) \ iso (reduced_homology_group p X) (reduced_homology_group p Y)" proof (rule group_isomorphisms_imp_iso) show "group_isomorphisms (reduced_homology_group p X) (reduced_homology_group p Y) (hom_induced p X {} Y {} f) (hom_induced p Y {} X {} g)" by (simp add: assms homotopy_equivalence_reduced_homology_group_isomorphisms) qed lemma homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups: "X homotopy_equivalent_space Y \ reduced_homology_group p X \ reduced_homology_group p Y" unfolding homotopy_equivalent_space_def using homotopy_equivalence_reduced_homology_group_isomorphism is_isoI by blast lemma homeomorphic_space_imp_isomorphic_reduced_homology_groups: "X homeomorphic_space Y \ reduced_homology_group p X \ reduced_homology_group p Y" by (simp add: homeomorphic_imp_homotopy_equivalent_space homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups) lemma trivial_reduced_homology_group_empty: "topspace X = {} \ trivial_group(reduced_homology_group p X)" by (metis carrier_reduced_homology_group_subset group.trivial_group_alt group_reduced_homology_group trivial_group_def trivial_homology_group_empty) lemma homology_dimension_reduced: assumes "topspace X = {a}" shows "trivial_group (reduced_homology_group p X)" proof - have iso: "(hom_induced p X {} (discrete_topology {()}) {} (\x. ())) \ iso (homology_group p X) (homology_group p (discrete_topology {()}))" apply (rule homeomorphic_map_homology_iso) apply (force simp: homeomorphic_map_maps homeomorphic_maps_def assms) done show ?thesis unfolding reduced_homology_group_def by (rule group.trivial_group_subgroup_generated) (use iso in \auto simp: iso_kernel_image\) qed lemma trivial_reduced_homology_group_contractible_space: "contractible_space X \ trivial_group (reduced_homology_group p X)" apply (simp add: contractible_eq_homotopy_equivalent_singleton_subtopology) apply (auto simp: trivial_reduced_homology_group_empty) using isomorphic_group_triviality by (metis (full_types) group_reduced_homology_group homology_dimension_reduced homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups path_connectedin_def path_connectedin_singleton topspace_subtopology_subset) lemma image_reduced_homology_group: assumes "topspace X \ S \ {}" shows "hom_induced p X {} X S id ` carrier (reduced_homology_group p X) = hom_induced p X {} X S id ` carrier (homology_group p X)" (is "?h ` carrier ?G = ?h ` carrier ?H") proof - obtain a where a: "a \ topspace X" and "a \ S" using assms by blast have [simp]: "A \ {x \ A. P x} = {x \ A. P x}" for A P by blast interpret comm_group "homology_group p X" by (rule abelian_relative_homology_group) have *: "\x'. ?h y = ?h x' \ x' \ carrier ?H \ hom_induced p X {} (discrete_topology {()}) {} (\x. ()) x' = \\<^bsub>homology_group p (discrete_topology {()})\<^esub>" if "y \ carrier ?H" for y proof - let ?f = "hom_induced p (discrete_topology {()}) {} X {} (\x. a)" let ?g = "hom_induced p X {} (discrete_topology {()}) {} (\x. ())" have bcarr: "?f (?g y) \ carrier ?H" by (simp add: hom_induced_carrier) interpret gh1: group_hom "relative_homology_group p X S" "relative_homology_group p (discrete_topology {()}) {()}" "hom_induced p X S (discrete_topology {()}) {()} (\x. ())" by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group) interpret gh2: group_hom "relative_homology_group p (discrete_topology {()}) {()}" "relative_homology_group p X S" "hom_induced p (discrete_topology {()}) {()} X S (\x. a)" by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group) interpret gh3: group_hom "homology_group p X" "relative_homology_group p X S" "?h" by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group) interpret gh4: group_hom "homology_group p X" "homology_group p (discrete_topology {()})" "?g" by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group) interpret gh5: group_hom "homology_group p (discrete_topology {()})" "homology_group p X" "?f" by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group) interpret gh6: group_hom "homology_group p (discrete_topology {()})" "relative_homology_group p (discrete_topology {()}) {()}" "hom_induced p (discrete_topology {()}) {} (discrete_topology {()}) {()} id" by (meson group_hom_axioms_def group_hom_def hom_induced_hom group_relative_homology_group) show ?thesis proof (intro exI conjI) have "(?h \ ?f \ ?g) y = (hom_induced p (discrete_topology {()}) {()} X S (\x. a) \ hom_induced p (discrete_topology {()}) {} (discrete_topology {()}) {()} id \ ?g) y" by (simp add: a \a \ S\ flip: hom_induced_compose) also have "\ = \\<^bsub>relative_homology_group p X S\<^esub>" using trivial_relative_homology_group_topspace [of p "discrete_topology {()}"] apply simp by (metis (full_types) empty_iff gh1.H.one_closed gh1.H.trivial_group gh2.hom_one hom_induced_carrier insert_iff) finally have "?h (?f (?g y)) = \\<^bsub>relative_homology_group p X S\<^esub>" by simp then show "?h y = ?h (y \\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> ?f (?g y))" by (simp add: that hom_induced_carrier) show "(y \\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> ?f (?g y)) \ carrier (homology_group p X)" by (simp add: hom_induced_carrier that) have *: "(?g \ hom_induced p X {} X {} (\x. a)) y = hom_induced p X {} (discrete_topology {()}) {} (\a. ()) y" by (simp add: a \a \ S\ flip: hom_induced_compose) have "?g (y \\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> (?f \ ?g) y) = \\<^bsub>homology_group p (discrete_topology {()})\<^esub>" by (simp add: a \a \ S\ that hom_induced_carrier flip: hom_induced_compose * [unfolded o_def]) then show "?g (y \\<^bsub>?H\<^esub> inv\<^bsub>?H\<^esub> ?f (?g y)) = \\<^bsub>homology_group p (discrete_topology {()})\<^esub>" by simp qed qed show ?thesis apply (auto simp: reduced_homology_group_def carrier_subgroup_generated kernel_def image_iff) apply (metis (no_types, lifting) generate_in_carrier mem_Collect_eq subsetI) apply (force simp: dest: * intro: generate.incl) done qed lemma homology_exactness_reduced_1: assumes "topspace X \ S \ {}" shows "exact_seq([reduced_homology_group(p - 1) (subtopology X S), relative_homology_group p X S, reduced_homology_group p X], [hom_boundary p X S, hom_induced p X {} X S id])" (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])") proof - have *: "?h2 ` carrier (homology_group p X) = kernel ?G2 (homology_group (p - 1) (subtopology X S)) ?h1" using homology_exactness_axiom_1 [of p X S] by simp have gh: "group_hom ?G3 ?G2 ?h2" by (simp add: reduced_homology_group_def group_hom_def group_hom_axioms_def group.group_subgroup_generated group.hom_from_subgroup_generated hom_induced_hom) show ?thesis apply (simp add: hom_boundary_reduced_hom gh * image_reduced_homology_group [OF assms]) apply (simp add: kernel_def one_reduced_homology_group) done qed lemma homology_exactness_reduced_2: "exact_seq([reduced_homology_group(p - 1) X, reduced_homology_group(p - 1) (subtopology X S), relative_homology_group p X S], [hom_induced (p - 1) (subtopology X S) {} X {} id, hom_boundary p X S])" (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])") using homology_exactness_axiom_2 [of p X S] apply (simp add: group_hom_axioms_def group_hom_def hom_boundary_reduced_hom hom_induced_reduced_hom) apply (simp add: reduced_homology_group_def group_hom.subgroup_kernel group_hom_axioms_def group_hom_def hom_induced_hom) using hom_boundary_reduced_hom [of p X S] apply (auto simp: image_def set_eq_iff) by (metis carrier_reduced_homology_group hom_in_carrier set_eq_iff) lemma homology_exactness_reduced_3: "exact_seq([relative_homology_group p X S, reduced_homology_group p X, reduced_homology_group p (subtopology X S)], [hom_induced p X {} X S id, hom_induced p (subtopology X S) {} X {} id])" (is "exact_seq ([?G1,?G2,?G3], [?h1,?h2])") proof - have "kernel ?G2 ?G1 ?h1 = ?h2 ` carrier ?G3" proof - obtain U where U: "(hom_induced p (subtopology X S) {} X {} id) ` carrier ?G3 \ U" "(hom_induced p (subtopology X S) {} X {} id) ` carrier ?G3 \ (hom_induced p (subtopology X S) {} X {} id) ` carrier (homology_group p (subtopology X S))" "U \ kernel (homology_group p X) ?G1 (hom_induced p X {} X S id) = kernel ?G2 ?G1 (hom_induced p X {} X S id)" "U \ (hom_induced p (subtopology X S) {} X {} id) ` carrier (homology_group p (subtopology X S)) \ (hom_induced p (subtopology X S) {} X {} id) ` carrier ?G3" proof show "?h2 ` carrier ?G3 \ carrier ?G2" by (simp add: hom_induced_reduced image_subset_iff) show "?h2 ` carrier ?G3 \ ?h2 ` carrier (homology_group p (subtopology X S))" by (meson carrier_reduced_homology_group_subset image_mono) have "subgroup (kernel (homology_group p X) (homology_group p (discrete_topology {()})) (hom_induced p X {} (discrete_topology {()}) {} (\x. ()))) (homology_group p X)" by (simp add: group.normal_invE(1) group_hom.normal_kernel group_hom_axioms_def group_hom_def hom_induced_empty_hom) then show "carrier ?G2 \ kernel (homology_group p X) ?G1 ?h1 = kernel ?G2 ?G1 ?h1" unfolding carrier_reduced_homology_group by (auto simp: reduced_homology_group_def) show "carrier ?G2 \ ?h2 ` carrier (homology_group p (subtopology X S)) \ ?h2 ` carrier ?G3" by (force simp: carrier_reduced_homology_group kernel_def hom_induced_compose') qed with homology_exactness_axiom_3 [of p X S] show ?thesis by (fastforce simp add:) qed then show ?thesis apply (simp add: group_hom_axioms_def group_hom_def hom_boundary_reduced_hom hom_induced_reduced_hom) apply (simp add: group.hom_from_subgroup_generated hom_induced_hom reduced_homology_group_def) done qed subsection\More homology properties of deformations, retracts, contractible spaces\ lemma iso_relative_homology_of_contractible: "\contractible_space X; topspace X \ S \ {}\ \ hom_boundary p X S \ iso (relative_homology_group p X S) (reduced_homology_group(p - 1) (subtopology X S))" using very_short_exact_sequence [of "reduced_homology_group (p - 1) X" "reduced_homology_group (p - 1) (subtopology X S)" "relative_homology_group p X S" "reduced_homology_group p X" "hom_induced (p - 1) (subtopology X S) {} X {} id" "hom_boundary p X S" "hom_induced p X {} X S id"] by (meson exact_seq_cons_iff homology_exactness_reduced_1 homology_exactness_reduced_2 trivial_reduced_homology_group_contractible_space) lemma isomorphic_group_relative_homology_of_contractible: "\contractible_space X; topspace X \ S \ {}\ \ relative_homology_group p X S \ reduced_homology_group(p - 1) (subtopology X S)" by (meson iso_relative_homology_of_contractible is_isoI) lemma isomorphic_group_reduced_homology_of_contractible: "\contractible_space X; topspace X \ S \ {}\ \ reduced_homology_group p (subtopology X S) \ relative_homology_group(p + 1) X S" by (metis add.commute add_diff_cancel_left' group.iso_sym group_relative_homology_group isomorphic_group_relative_homology_of_contractible) lemma iso_reduced_homology_by_contractible: "\contractible_space(subtopology X S); topspace X \ S \ {}\ \ (hom_induced p X {} X S id) \ iso (reduced_homology_group p X) (relative_homology_group p X S)" using very_short_exact_sequence [of "reduced_homology_group (p - 1) (subtopology X S)" "relative_homology_group p X S" "reduced_homology_group p X" "reduced_homology_group p (subtopology X S)" "hom_boundary p X S" "hom_induced p X {} X S id" "hom_induced p (subtopology X S) {} X {} id"] by (meson exact_seq_cons_iff homology_exactness_reduced_1 homology_exactness_reduced_3 trivial_reduced_homology_group_contractible_space) lemma isomorphic_reduced_homology_by_contractible: "\contractible_space(subtopology X S); topspace X \ S \ {}\ \ reduced_homology_group p X \ relative_homology_group p X S" using is_isoI iso_reduced_homology_by_contractible by blast lemma isomorphic_relative_homology_by_contractible: "\contractible_space(subtopology X S); topspace X \ S \ {}\ \ relative_homology_group p X S \ reduced_homology_group p X" using group.iso_sym group_reduced_homology_group isomorphic_reduced_homology_by_contractible by blast lemma isomorphic_reduced_homology_by_singleton: "a \ topspace X \ reduced_homology_group p X \ relative_homology_group p X ({a})" by (simp add: contractible_space_subtopology_singleton isomorphic_reduced_homology_by_contractible) lemma isomorphic_relative_homology_by_singleton: "a \ topspace X \ relative_homology_group p X ({a}) \ reduced_homology_group p X" by (simp add: group.iso_sym isomorphic_reduced_homology_by_singleton) lemma reduced_homology_group_pair: assumes "t1_space X" and a: "a \ topspace X" and b: "b \ topspace X" and "a \ b" shows "reduced_homology_group p (subtopology X {a,b}) \ homology_group p (subtopology X {a})" (is "?lhs \ ?rhs") proof - have "?lhs \ relative_homology_group p (subtopology X {a,b}) {b}" by (simp add: b isomorphic_reduced_homology_by_singleton topspace_subtopology) also have "\ \ ?rhs" proof - have sub: "subtopology X {a, b} closure_of {b} \ subtopology X {a, b} interior_of {b}" by (simp add: assms t1_space_subtopology closure_of_singleton subtopology_eq_discrete_topology_finite discrete_topology_closure_of) show ?thesis using homology_excision_axiom [OF sub, of "{a,b}" p] by (simp add: assms(4) group.iso_sym is_isoI subtopology_subtopology) qed finally show ?thesis . qed lemma deformation_retraction_relative_homology_group_isomorphisms: "\retraction_maps X Y r s; r ` U \ V; s ` V \ U; homotopic_with (\h. h ` U \ U) X X (s \ r) id\ \ group_isomorphisms (relative_homology_group p X U) (relative_homology_group p Y V) (hom_induced p X U Y V r) (hom_induced p Y V X U s)" apply (simp add: retraction_maps_def) apply (rule homotopy_equivalence_relative_homology_group_isomorphisms) apply (auto simp: image_subset_iff continuous_map_compose homotopic_with_equal) done lemma deformation_retract_relative_homology_group_isomorphisms: "\retraction_maps X Y r id; V \ U; r ` U \ V; homotopic_with (\h. h ` U \ U) X X r id\ \ group_isomorphisms (relative_homology_group p X U) (relative_homology_group p Y V) (hom_induced p X U Y V r) (hom_induced p Y V X U id)" by (simp add: deformation_retraction_relative_homology_group_isomorphisms) lemma deformation_retract_relative_homology_group_isomorphism: "\retraction_maps X Y r id; V \ U; r ` U \ V; homotopic_with (\h. h ` U \ U) X X r id\ \ (hom_induced p X U Y V r) \ iso (relative_homology_group p X U) (relative_homology_group p Y V)" by (metis deformation_retract_relative_homology_group_isomorphisms group_isomorphisms_imp_iso) lemma deformation_retract_relative_homology_group_isomorphism_id: "\retraction_maps X Y r id; V \ U; r ` U \ V; homotopic_with (\h. h ` U \ U) X X r id\ \ (hom_induced p Y V X U id) \ iso (relative_homology_group p Y V) (relative_homology_group p X U)" by (metis deformation_retract_relative_homology_group_isomorphisms group_isomorphisms_imp_iso group_isomorphisms_sym) lemma deformation_retraction_imp_isomorphic_relative_homology_groups: "\retraction_maps X Y r s; r ` U \ V; s ` V \ U; homotopic_with (\h. h ` U \ U) X X (s \ r) id\ \ relative_homology_group p X U \ relative_homology_group p Y V" by (blast intro: is_isoI group_isomorphisms_imp_iso deformation_retraction_relative_homology_group_isomorphisms) lemma deformation_retraction_imp_isomorphic_homology_groups: "\retraction_maps X Y r s; homotopic_with (\h. True) X X (s \ r) id\ \ homology_group p X \ homology_group p Y" by (simp add: deformation_retraction_imp_homotopy_equivalent_space homotopy_equivalent_space_imp_isomorphic_homology_groups) lemma deformation_retract_imp_isomorphic_relative_homology_groups: "\retraction_maps X X' r id; V \ U; r ` U \ V; homotopic_with (\h. h ` U \ U) X X r id\ \ relative_homology_group p X U \ relative_homology_group p X' V" by (simp add: deformation_retraction_imp_isomorphic_relative_homology_groups) lemma deformation_retract_imp_isomorphic_homology_groups: "\retraction_maps X X' r id; homotopic_with (\h. True) X X r id\ \ homology_group p X \ homology_group p X'" by (simp add: deformation_retraction_imp_isomorphic_homology_groups) lemma epi_hom_induced_inclusion: assumes "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" shows "(hom_induced p (subtopology X S) {} X {} id) \ epi (homology_group p (subtopology X S)) (homology_group p X)" proof (rule epi_right_invertible) show "hom_induced p (subtopology X S) {} X {} id \ hom (homology_group p (subtopology X S)) (homology_group p X)" by (simp add: hom_induced_empty_hom) show "hom_induced p X {} (subtopology X S) {} f \ carrier (homology_group p X) \ carrier (homology_group p (subtopology X S))" by (simp add: hom_induced_carrier) fix x assume "x \ carrier (homology_group p X)" then show "hom_induced p (subtopology X S) {} X {} id (hom_induced p X {} (subtopology X S) {} f x) = x" by (metis assms continuous_map_id_subt continuous_map_in_subtopology hom_induced_compose' hom_induced_id homology_homotopy_empty homotopic_with_imp_continuous_maps image_empty order_refl) qed lemma trivial_homomorphism_hom_induced_relativization: assumes "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" shows "trivial_homomorphism (homology_group p X) (relative_homology_group p X S) (hom_induced p X {} X S id)" proof - have "(hom_induced p (subtopology X S) {} X {} id) \ epi (homology_group p (subtopology X S)) (homology_group p X)" by (metis assms epi_hom_induced_inclusion) then show ?thesis using homology_exactness_axiom_3 [of p X S] homology_exactness_axiom_1 [of p X S] by (simp add: epi_def group.trivial_homomorphism_image group_hom.trivial_hom_iff) qed lemma mon_hom_boundary_inclusion: assumes "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" shows "(hom_boundary p X S) \ mon (relative_homology_group p X S) (homology_group (p - 1) (subtopology X S))" proof - have "(hom_induced p (subtopology X S) {} X {} id) \ epi (homology_group p (subtopology X S)) (homology_group p X)" by (metis assms epi_hom_induced_inclusion) then show ?thesis using homology_exactness_axiom_3 [of p X S] homology_exactness_axiom_1 [of p X S] apply (simp add: mon_def epi_def hom_boundary_hom) by (metis (no_types, hide_lams) group_hom.trivial_hom_iff group_hom.trivial_ker_imp_inj group_hom_axioms_def group_hom_def group_relative_homology_group hom_boundary_hom) qed lemma short_exact_sequence_hom_induced_relativization: assumes "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" shows "short_exact_sequence (homology_group (p-1) X) (homology_group (p-1) (subtopology X S)) (relative_homology_group p X S) (hom_induced (p-1) (subtopology X S) {} X {} id) (hom_boundary p X S)" unfolding short_exact_sequence_iff by (intro conjI homology_exactness_axiom_2 epi_hom_induced_inclusion [OF assms] mon_hom_boundary_inclusion [OF assms]) lemma group_isomorphisms_homology_group_prod_deformation: fixes p::int assumes "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" obtains H K where "subgroup H (homology_group p (subtopology X S))" "subgroup K (homology_group p (subtopology X S))" "(\(x, y). x \\<^bsub>homology_group p (subtopology X S)\<^esub> y) \ Group.iso (subgroup_generated (homology_group p (subtopology X S)) H \\ subgroup_generated (homology_group p (subtopology X S)) K) (homology_group p (subtopology X S))" "hom_boundary (p + 1) X S \ Group.iso (relative_homology_group (p + 1) X S) (subgroup_generated (homology_group p (subtopology X S)) H)" "hom_induced p (subtopology X S) {} X {} id \ Group.iso (subgroup_generated (homology_group p (subtopology X S)) K) (homology_group p X)" proof - let ?rhs = "relative_homology_group (p + 1) X S" let ?pXS = "homology_group p (subtopology X S)" let ?pX = "homology_group p X" let ?hb = "hom_boundary (p + 1) X S" let ?hi = "hom_induced p (subtopology X S) {} X {} id" have x: "short_exact_sequence (?pX) ?pXS ?rhs ?hi ?hb" using short_exact_sequence_hom_induced_relativization [OF assms, of "p + 1"] by simp have contf: "continuous_map X (subtopology X S) f" by (meson assms continuous_map_in_subtopology homotopic_with_imp_continuous_maps) obtain H K where HK: "H \ ?pXS" "subgroup K ?pXS" "H \ K \ {one ?pXS}" "set_mult ?pXS H K = carrier ?pXS" and iso: "?hb \ iso ?rhs (subgroup_generated ?pXS H)" "?hi \ iso (subgroup_generated ?pXS K) ?pX" apply (rule splitting_lemma_right [OF x, where g' = "hom_induced p X {} (subtopology X S) {} f"]) apply (simp add: hom_induced_empty_hom) apply (simp add: contf hom_induced_compose') apply (metis (full_types) assms(1) hom_induced_id homology_homotopy_empty) apply blast done show ?thesis proof show "subgroup H ?pXS" using HK(1) normal_imp_subgroup by blast then show "(\(x, y). x \\<^bsub>?pXS\<^esub> y) \ Group.iso (subgroup_generated (?pXS) H \\ subgroup_generated (?pXS) K) (?pXS)" by (meson HK abelian_relative_homology_group group_disjoint_sum.iso_group_mul group_disjoint_sum_def group_relative_homology_group) show "subgroup K ?pXS" by (rule HK) show "hom_boundary (p + 1) X S \ Group.iso ?rhs (subgroup_generated (?pXS) H)" using iso int_ops(4) by presburger show "hom_induced p (subtopology X S) {} X {} id \ Group.iso (subgroup_generated (?pXS) K) (?pX)" by (simp add: iso(2)) qed qed lemma iso_homology_group_prod_deformation: assumes "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" shows "homology_group p (subtopology X S) \ DirProd (homology_group p X) (relative_homology_group(p + 1) X S)" (is "?G \ DirProd ?H ?R") proof - obtain H K where HK: "(\(x, y). x \\<^bsub>?G\<^esub> y) \ Group.iso (subgroup_generated (?G) H \\ subgroup_generated (?G) K) (?G)" "hom_boundary (p + 1) X S \ Group.iso (?R) (subgroup_generated (?G) H)" "hom_induced p (subtopology X S) {} X {} id \ Group.iso (subgroup_generated (?G) K) (?H)" by (blast intro: group_isomorphisms_homology_group_prod_deformation [OF assms]) have "?G \ DirProd (subgroup_generated (?G) H) (subgroup_generated (?G) K)" by (meson DirProd_group HK(1) group.group_subgroup_generated group.iso_sym group_relative_homology_group is_isoI) also have "\ \ DirProd ?R ?H" by (meson HK group.DirProd_iso_trans group.group_subgroup_generated group.iso_sym group_relative_homology_group is_isoI) also have "\ \ DirProd ?H ?R" by (simp add: DirProd_commute_iso) finally show ?thesis . qed lemma iso_homology_contractible_space_subtopology1: assumes "contractible_space X" "S \ topspace X" "S \ {}" shows "homology_group 0 (subtopology X S) \ DirProd integer_group (relative_homology_group(1) X S)" proof - obtain f where "homotopic_with (\x. True) X X id f" and "f ` (topspace X) \ S" using assms contractible_space_alt by fastforce then have "homology_group 0 (subtopology X S) \ homology_group 0 X \\ relative_homology_group 1 X S" using iso_homology_group_prod_deformation [of X _ S 0] by auto also have "\ \ integer_group \\ relative_homology_group 1 X S" using assms contractible_imp_path_connected_space group.DirProd_iso_trans group_relative_homology_group iso_refl isomorphic_integer_zeroth_homology_group by blast finally show ?thesis . qed lemma iso_homology_contractible_space_subtopology2: "\contractible_space X; S \ topspace X; p \ 0; S \ {}\ \ homology_group p (subtopology X S) \ relative_homology_group (p + 1) X S" by (metis (no_types, hide_lams) add.commute isomorphic_group_reduced_homology_of_contractible topspace_subtopology topspace_subtopology_subset un_reduced_homology_group) lemma trivial_relative_homology_group_contractible_spaces: "\contractible_space X; contractible_space(subtopology X S); topspace X \ S \ {}\ \ trivial_group(relative_homology_group p X S)" using group_reduced_homology_group group_relative_homology_group isomorphic_group_triviality isomorphic_relative_homology_by_contractible trivial_reduced_homology_group_contractible_space by blast lemma trivial_relative_homology_group_alt: assumes contf: "continuous_map X (subtopology X S) f" and hom: "homotopic_with (\k. k ` S \ S) X X f id" shows "trivial_group (relative_homology_group p X S)" proof (rule trivial_relative_homology_group_gen [OF contf]) show "homotopic_with (\h. True) (subtopology X S) (subtopology X S) f id" using hom unfolding homotopic_with_def apply (rule ex_forward) apply (auto simp: prod_topology_subtopology continuous_map_in_subtopology continuous_map_from_subtopology image_subset_iff topspace_subtopology) done show "homotopic_with (\k. True) X X f id" using assms by (force simp: homotopic_with_def) qed lemma iso_hom_induced_relativization_contractible: assumes "contractible_space(subtopology X S)" "contractible_space(subtopology X T)" "T \ S" "topspace X \ T \ {}" shows "(hom_induced p X T X S id) \ iso (relative_homology_group p X T) (relative_homology_group p X S)" proof (rule very_short_exact_sequence) show "exact_seq ([relative_homology_group(p - 1) (subtopology X S) T, relative_homology_group p X S, relative_homology_group p X T, relative_homology_group p (subtopology X S) T], [hom_relboundary p X S T, hom_induced p X T X S id, hom_induced p (subtopology X S) T X T id])" using homology_exactness_triple_1 [OF \T \ S\] homology_exactness_triple_3 [OF \T \ S\] by fastforce show "trivial_group (relative_homology_group p (subtopology X S) T)" "trivial_group (relative_homology_group(p - 1) (subtopology X S) T)" using assms by (force simp: inf.absorb_iff2 subtopology_subtopology topspace_subtopology intro!: trivial_relative_homology_group_contractible_spaces)+ qed corollary isomorphic_relative_homology_groups_relativization_contractible: assumes "contractible_space(subtopology X S)" "contractible_space(subtopology X T)" "T \ S" "topspace X \ T \ {}" shows "relative_homology_group p X T \ relative_homology_group p X S" by (rule is_isoI) (rule iso_hom_induced_relativization_contractible [OF assms]) lemma iso_hom_induced_inclusion_contractible: assumes "contractible_space X" "contractible_space(subtopology X S)" "T \ S" "topspace X \ S \ {}" shows "(hom_induced p (subtopology X S) T X T id) \ iso (relative_homology_group p (subtopology X S) T) (relative_homology_group p X T)" proof (rule very_short_exact_sequence) show "exact_seq ([relative_homology_group p X S, relative_homology_group p X T, relative_homology_group p (subtopology X S) T, relative_homology_group (p+1) X S], [hom_induced p X T X S id, hom_induced p (subtopology X S) T X T id, hom_relboundary (p+1) X S T])" using homology_exactness_triple_2 [OF \T \ S\] homology_exactness_triple_3 [OF \T \ S\] by (metis add_diff_cancel_left' diff_add_cancel exact_seq_cons_iff) show "trivial_group (relative_homology_group (p+1) X S)" "trivial_group (relative_homology_group p X S)" using assms by (auto simp: subtopology_subtopology topspace_subtopology intro!: trivial_relative_homology_group_contractible_spaces) qed corollary isomorphic_relative_homology_groups_inclusion_contractible: assumes "contractible_space X" "contractible_space(subtopology X S)" "T \ S" "topspace X \ S \ {}" shows "relative_homology_group p (subtopology X S) T \ relative_homology_group p X T" by (rule is_isoI) (rule iso_hom_induced_inclusion_contractible [OF assms]) lemma iso_hom_relboundary_contractible: assumes "contractible_space X" "contractible_space(subtopology X T)" "T \ S" "topspace X \ T \ {}" shows "hom_relboundary p X S T \ iso (relative_homology_group p X S) (relative_homology_group (p - 1) (subtopology X S) T)" proof (rule very_short_exact_sequence) show "exact_seq ([relative_homology_group (p - 1) X T, relative_homology_group (p - 1) (subtopology X S) T, relative_homology_group p X S, relative_homology_group p X T], [hom_induced (p - 1) (subtopology X S) T X T id, hom_relboundary p X S T, hom_induced p X T X S id])" using homology_exactness_triple_1 [OF \T \ S\] homology_exactness_triple_2 [OF \T \ S\] by simp show "trivial_group (relative_homology_group p X T)" "trivial_group (relative_homology_group (p - 1) X T)" using assms by (auto simp: subtopology_subtopology topspace_subtopology intro!: trivial_relative_homology_group_contractible_spaces) qed corollary isomorphic_relative_homology_groups_relboundary_contractible: assumes "contractible_space X" "contractible_space(subtopology X T)" "T \ S" "topspace X \ T \ {}" shows "relative_homology_group p X S \ relative_homology_group (p - 1) (subtopology X S) T" by (rule is_isoI) (rule iso_hom_relboundary_contractible [OF assms]) lemma isomorphic_relative_contractible_space_imp_homology_groups: assumes "contractible_space X" "contractible_space Y" "S \ topspace X" "T \ topspace Y" and ST: "S = {} \ T = {}" and iso: "\p. relative_homology_group p X S \ relative_homology_group p Y T" shows "homology_group p (subtopology X S) \ homology_group p (subtopology Y T)" proof (cases "T = {}") case True have "homology_group p (subtopology X {}) \ homology_group p (subtopology Y {})" by (simp add: homeomorphic_empty_space_eq homeomorphic_space_imp_isomorphic_homology_groups) then show ?thesis using ST True by blast next case False show ?thesis proof (cases "p = 0") case True have "homology_group p (subtopology X S) \ integer_group \\ relative_homology_group 1 X S" using assms True \T \ {}\ by (simp add: iso_homology_contractible_space_subtopology1) also have "\ \ integer_group \\ relative_homology_group 1 Y T" by (simp add: assms group.DirProd_iso_trans iso_refl) also have "\ \ homology_group p (subtopology Y T)" by (simp add: True \T \ {}\ assms group.iso_sym iso_homology_contractible_space_subtopology1) finally show ?thesis . next case False have "homology_group p (subtopology X S) \ relative_homology_group (p+1) X S" using assms False \T \ {}\ by (simp add: iso_homology_contractible_space_subtopology2) also have "\ \ relative_homology_group (p+1) Y T" by (simp add: assms) also have "\ \ homology_group p (subtopology Y T)" by (simp add: False \T \ {}\ assms group.iso_sym iso_homology_contractible_space_subtopology2) finally show ?thesis . qed qed subsection\Homology groups of spheres\ lemma iso_reduced_homology_group_lower_hemisphere: assumes "k \ n" shows "hom_induced p (nsphere n) {} (nsphere n) {x. x k \ 0} id \ iso (reduced_homology_group p (nsphere n)) (relative_homology_group p (nsphere n) {x. x k \ 0})" proof (rule iso_reduced_homology_by_contractible) show "contractible_space (subtopology (nsphere n) {x. x k \ 0})" by (simp add: assms contractible_space_lower_hemisphere) have "(\i. if i = k then -1 else 0) \ topspace (nsphere n) \ {x. x k \ 0}" using assms by (simp add: nsphere if_distrib [of "\x. x ^ 2"] cong: if_cong) then show "topspace (nsphere n) \ {x. x k \ 0} \ {}" by blast qed lemma topspace_nsphere_1: assumes "x \ topspace (nsphere n)" shows "(x k)\<^sup>2 \ 1" proof (cases "k \ n") case True have "(\i \ {..n} - {k}. (x i)\<^sup>2) = (\i\n. (x i)\<^sup>2) - (x k)\<^sup>2" using \k \ n\ by (simp add: sum_diff) then show ?thesis using assms apply (simp add: nsphere) by (metis diff_ge_0_iff_ge sum_nonneg zero_le_power2) next case False then show ?thesis using assms by (simp add: nsphere) qed lemma topspace_nsphere_1_eq_0: fixes x :: "nat \ real" assumes x: "x \ topspace (nsphere n)" and xk: "(x k)\<^sup>2 = 1" and "i \ k" shows "x i = 0" proof (cases "i \ n") case True have "k \ n" using x by (simp add: nsphere) (metis not_less xk zero_neq_one zero_power2) have "(\i \ {..n} - {k}. (x i)\<^sup>2) = (\i\n. (x i)\<^sup>2) - (x k)\<^sup>2" using \k \ n\ by (simp add: sum_diff) also have "\ = 0" using assms by (simp add: nsphere) finally have "\i\{..n} - {k}. (x i)\<^sup>2 = 0" by (simp add: sum_nonneg_eq_0_iff) then show ?thesis using True \i \ k\ by auto next case False with x show ?thesis by (simp add: nsphere) qed proposition iso_relative_homology_group_upper_hemisphere: "(hom_induced p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0} (nsphere n) {x. x k \ 0} id) \ iso (relative_homology_group p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0}) (relative_homology_group p (nsphere n) {x. x k \ 0})" (is "?h \ iso ?G ?H") proof - have "topspace (nsphere n) \ {x. x k < - 1 / 2} \ {x \ topspace (nsphere n). x k \ {y. y \ - 1 / 2}}" by force moreover have "closedin (nsphere n) {x \ topspace (nsphere n). x k \ {y. y \ - 1 / 2}}" apply (rule closedin_continuous_map_preimage [OF continuous_map_nsphere_projection]) using closed_Collect_le [of id "\x::real. -1/2"] apply simp done ultimately have "nsphere n closure_of {x. x k < -1/2} \ {x \ topspace (nsphere n). x k \ {y. y \ -1/2}}" by (metis (no_types, lifting) closure_of_eq closure_of_mono closure_of_restrict) also have "\ \ {x \ topspace (nsphere n). x k \ {y. y < 0}}" by force also have "\ \ nsphere n interior_of {x. x k \ 0}" proof (rule interior_of_maximal) show "{x \ topspace (nsphere n). x k \ {y. y < 0}} \ {x. x k \ 0}" by force show "openin (nsphere n) {x \ topspace (nsphere n). x k \ {y. y < 0}}" apply (rule openin_continuous_map_preimage [OF continuous_map_nsphere_projection]) using open_Collect_less [of id "\x::real. 0"] apply simp done qed finally have nn: "nsphere n closure_of {x. x k < -1/2} \ nsphere n interior_of {x. x k \ 0}" . have [simp]: "{x::nat\real. x k \ 0} - {x. x k < - (1/2)} = {x. -1/2 \ x k \ x k \ 0}" "UNIV - {x::nat\real. x k < a} = {x. a \ x k}" for a by auto let ?T01 = "top_of_set {0..1::real}" let ?X12 = "subtopology (nsphere n) {x. -1/2 \ x k}" have 1: "hom_induced p ?X12 {x. -1/2 \ x k \ x k \ 0} (nsphere n) {x. x k \ 0} id \ iso (relative_homology_group p ?X12 {x. -1/2 \ x k \ x k \ 0}) ?H" using homology_excision_axiom [OF nn subset_UNIV, of p] by simp define h where "h \ \(T,x). let y = max (x k) (-T) in (\i. if i = k then y else sqrt(1 - y ^ 2) / sqrt(1 - x k ^ 2) * x i)" have h: "h(T,x) = x" if "0 \ T" "T \ 1" "(\i\n. (x i)\<^sup>2) = 1" and 0: "\i>n. x i = 0" "-T \ x k" for T x using that by (force simp: nsphere h_def Let_def max_def intro!: topspace_nsphere_1_eq_0) have "continuous_map (prod_topology ?T01 ?X12) euclideanreal (\x. h x i)" for i proof - show ?thesis proof (rule continuous_map_eq) show "continuous_map (prod_topology ?T01 ?X12) euclideanreal (\(T, x). if 0 \ x k then x i else h (T, x) i)" unfolding case_prod_unfold proof (rule continuous_map_cases_le) show "continuous_map (prod_topology ?T01 ?X12) euclideanreal (\x. snd x k)" apply (subst continuous_map_of_snd [unfolded o_def]) by (simp add: continuous_map_from_subtopology continuous_map_nsphere_projection) next show "continuous_map (subtopology (prod_topology ?T01 ?X12) {p \ topspace (prod_topology ?T01 ?X12). 0 \ snd p k}) euclideanreal (\x. snd x i)" apply (rule continuous_map_from_subtopology) apply (subst continuous_map_of_snd [unfolded o_def]) by (simp add: continuous_map_from_subtopology continuous_map_nsphere_projection) next note fst = continuous_map_into_fulltopology [OF continuous_map_subtopology_fst] have snd: "continuous_map (subtopology (prod_topology ?T01 (subtopology (nsphere n) T)) S) euclideanreal (\x. snd x k)" for k S T apply (simp add: nsphere) apply (rule continuous_map_from_subtopology) apply (subst continuous_map_of_snd [unfolded o_def]) using continuous_map_from_subtopology continuous_map_nsphere_projection nsphere by fastforce show "continuous_map (subtopology (prod_topology ?T01 ?X12) {p \ topspace (prod_topology ?T01 ?X12). snd p k \ 0}) euclideanreal (\x. h (fst x, snd x) i)" apply (simp add: h_def case_prod_unfold Let_def) apply (intro conjI impI fst snd continuous_intros) apply (auto simp: nsphere power2_eq_1_iff) done qed (auto simp: nsphere h) qed (auto simp: nsphere h) qed moreover have "h ` ({0..1} \ (topspace (nsphere n) \ {x. - (1/2) \ x k})) \ {x. (\i\n. (x i)\<^sup>2) = 1 \ (\i>n. x i = 0)}" proof - have "(\i\n. (h (T,x) i)\<^sup>2) = 1" if x: "x \ topspace (nsphere n)" and xk: "- (1/2) \ x k" and T: "0 \ T" "T \ 1" for T x proof (cases "-T \ x k ") case True then show ?thesis using that by (auto simp: nsphere h) next case False with x \0 \ T\ have "k \ n" apply (simp add: nsphere) by (metis neg_le_0_iff_le not_le) have "1 - (x k)\<^sup>2 \ 0" using topspace_nsphere_1 x by auto with False T \k \ n\ have "(\i\n. (h (T,x) i)\<^sup>2) = T\<^sup>2 + (1 - T\<^sup>2) * (\i\{..n} - {k}. (x i)\<^sup>2 / (1 - (x k)\<^sup>2))" unfolding h_def Let_def max_def by (simp add: not_le square_le_1 power_mult_distrib power_divide if_distrib [of "\x. x ^ 2"] sum.delta_remove sum_distrib_left) also have "\ = 1" using x False xk \0 \ T\ by (simp add: nsphere sum_diff not_le \k \ n\ power2_eq_1_iff flip: sum_divide_distrib) finally show ?thesis . qed moreover have "h (T,x) i = 0" if "x \ topspace (nsphere n)" "- (1/2) \ x k" and "n < i" "0 \ T" "T \ 1" for T x i proof (cases "-T \ x k ") case False then show ?thesis using that by (auto simp: nsphere h_def Let_def not_le max_def) qed (use that in \auto simp: nsphere h\) ultimately show ?thesis by auto qed ultimately have cmh: "continuous_map (prod_topology ?T01 ?X12) (nsphere n) h" by (subst (2) nsphere) (simp add: continuous_map_in_subtopology continuous_map_componentwise_UNIV) have "hom_induced p (subtopology (nsphere n) {x. 0 \ x k}) (topspace (subtopology (nsphere n) {x. 0 \ x k}) \ {x. x k = 0}) ?X12 (topspace ?X12 \ {x. - 1/2 \ x k \ x k \ 0}) id \ iso (relative_homology_group p (subtopology (nsphere n) {x. 0 \ x k}) (topspace (subtopology (nsphere n) {x. 0 \ x k}) \ {x. x k = 0})) (relative_homology_group p ?X12 (topspace ?X12 \ {x. - 1/2 \ x k \ x k \ 0}))" proof (rule deformation_retract_relative_homology_group_isomorphism_id) show "retraction_maps ?X12 (subtopology (nsphere n) {x. 0 \ x k}) (h \ (\x. (0,x))) id" unfolding retraction_maps_def proof (intro conjI ballI) show "continuous_map ?X12 (subtopology (nsphere n) {x. 0 \ x k}) (h \ Pair 0)" apply (simp add: continuous_map_in_subtopology) apply (intro conjI continuous_map_compose [OF _ cmh] continuous_intros) apply (auto simp: h_def Let_def) done show "continuous_map (subtopology (nsphere n) {x. 0 \ x k}) ?X12 id" by (simp add: continuous_map_in_subtopology) (auto simp: nsphere) qed (simp add: nsphere h) next have h0: "\xa. \xa \ topspace (nsphere n); - (1/2) \ xa k; xa k \ 0\ \ h (0, xa) k = 0" by (simp add: h_def Let_def) show "(h \ (\x. (0,x))) ` (topspace ?X12 \ {x. - 1 / 2 \ x k \ x k \ 0}) \ topspace (subtopology (nsphere n) {x. 0 \ x k}) \ {x. x k = 0}" apply (auto simp: h0) apply (rule subsetD [OF continuous_map_image_subset_topspace [OF cmh]]) apply (force simp: nsphere) done have hin: "\t x. \x \ topspace (nsphere n); - (1/2) \ x k; 0 \ t; t \ 1\ \ h (t,x) \ topspace (nsphere n)" apply (rule subsetD [OF continuous_map_image_subset_topspace [OF cmh]]) apply (force simp: nsphere) done have h1: "\x. \x \ topspace (nsphere n); - (1/2) \ x k\ \ h (1, x) = x" by (simp add: h nsphere) have "continuous_map (prod_topology ?T01 ?X12) (nsphere n) h" using cmh by force then show "homotopic_with (\h. h ` (topspace ?X12 \ {x. - 1 / 2 \ x k \ x k \ 0}) \ topspace ?X12 \ {x. - 1 / 2 \ x k \ x k \ 0}) ?X12 ?X12 (h \ (\x. (0,x))) id" apply (subst homotopic_with, force) apply (rule_tac x=h in exI) apply (auto simp: hin h1 continuous_map_in_subtopology) apply (auto simp: h_def Let_def max_def) done qed auto then have 2: "hom_induced p (subtopology (nsphere n) {x. 0 \ x k}) {x. x k = 0} ?X12 {x. - 1/2 \ x k \ x k \ 0} id \ Group.iso (relative_homology_group p (subtopology (nsphere n) {x. 0 \ x k}) {x. x k = 0}) (relative_homology_group p ?X12 {x. - 1/2 \ x k \ x k \ 0})" by (metis hom_induced_restrict relative_homology_group_restrict topspace_subtopology) show ?thesis using iso_set_trans [OF 2 1] by (simp add: subset_iff continuous_map_in_subtopology flip: hom_induced_compose) qed corollary iso_upper_hemisphere_reduced_homology_group: "(hom_boundary (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \ 0}) {x. x(Suc n) = 0}) \ iso (relative_homology_group (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \ 0}) {x. x(Suc n) = 0}) (reduced_homology_group p (nsphere n))" proof - have "{x. 0 \ x (Suc n)} \ {x. x (Suc n) = 0} = {x. x (Suc n) = (0::real)}" by auto then have n: "nsphere n = subtopology (subtopology (nsphere (Suc n)) {x. x(Suc n) \ 0}) {x. x(Suc n) = 0}" by (simp add: subtopology_nsphere_equator subtopology_subtopology) have ne: "(\i. if i = n then 1 else 0) \ topspace (subtopology (nsphere (Suc n)) {x. 0 \ x (Suc n)}) \ {x. x (Suc n) = 0}" by (simp add: nsphere if_distrib [of "\x. x ^ 2"] cong: if_cong) show ?thesis unfolding n apply (rule iso_relative_homology_of_contractible [where p = "1 + p", simplified]) using contractible_space_upper_hemisphere ne apply blast+ done qed corollary iso_reduced_homology_group_upper_hemisphere: assumes "k \ n" shows "hom_induced p (nsphere n) {} (nsphere n) {x. x k \ 0} id \ iso (reduced_homology_group p (nsphere n)) (relative_homology_group p (nsphere n) {x. x k \ 0})" proof (rule iso_reduced_homology_by_contractible [OF contractible_space_upper_hemisphere [OF assms]]) have "(\i. if i = k then 1 else 0) \ topspace (nsphere n) \ {x. 0 \ x k}" using assms by (simp add: nsphere if_distrib [of "\x. x ^ 2"] cong: if_cong) then show "topspace (nsphere n) \ {x. 0 \ x k} \ {}" by blast qed lemma iso_relative_homology_group_lower_hemisphere: "hom_induced p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0} (nsphere n) {x. x k \ 0} id \ iso (relative_homology_group p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0}) (relative_homology_group p (nsphere n) {x. x k \ 0})" (is "?k \ iso ?G ?H") proof - define r where "r \ \x i. if i = k then -x i else (x i::real)" then have [simp]: "r \ r = id" by force have cmr: "continuous_map (subtopology (nsphere n) S) (nsphere n) r" for S using continuous_map_nsphere_reflection [of n k] by (simp add: continuous_map_from_subtopology r_def) let ?f = "hom_induced p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0} (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0} r" let ?g = "hom_induced p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0} (nsphere n) {x. x k \ 0} id" let ?h = "hom_induced p (nsphere n) {x. x k \ 0} (nsphere n) {x. x k \ 0} r" obtain f h where f: "f \ iso ?G (relative_homology_group p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0})" and h: "h \ iso (relative_homology_group p (nsphere n) {x. x k \ 0}) ?H" and eq: "h \ ?g \ f = ?k" proof have hmr: "homeomorphic_map (nsphere n) (nsphere n) r" unfolding homeomorphic_map_maps by (metis \r \ r = id\ cmr homeomorphic_maps_involution pointfree_idE subtopology_topspace) then have hmrs: "homeomorphic_map (subtopology (nsphere n) {x. x k \ 0}) (subtopology (nsphere n) {x. x k \ 0}) r" by (simp add: homeomorphic_map_subtopologies_alt r_def) have rimeq: "r ` (topspace (subtopology (nsphere n) {x. x k \ 0}) \ {x. x k = 0}) = topspace (subtopology (nsphere n) {x. 0 \ x k}) \ {x. x k = 0}" using continuous_map_eq_topcontinuous_at continuous_map_nsphere_reflection topcontinuous_at_atin by (fastforce simp: r_def) show "?f \ iso ?G (relative_homology_group p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0})" using homeomorphic_map_relative_homology_iso [OF hmrs Int_lower1 rimeq] by (metis hom_induced_restrict relative_homology_group_restrict) have rimeq: "r ` (topspace (nsphere n) \ {x. x k \ 0}) = topspace (nsphere n) \ {x. 0 \ x k}" by (metis hmrs homeomorphic_imp_surjective_map topspace_subtopology) show "?h \ Group.iso (relative_homology_group p (nsphere n) {x. x k \ 0}) ?H" using homeomorphic_map_relative_homology_iso [OF hmr Int_lower1 rimeq] by simp have [simp]: "\x. x k = 0 \ r x k = 0" by (auto simp: r_def) have "?h \ ?g \ ?f = hom_induced p (subtopology (nsphere n) {x. 0 \ x k}) {x. x k = 0} (nsphere n) {x. 0 \ x k} r \ hom_induced p (subtopology (nsphere n) {x. x k \ 0}) {x. x k = 0} (subtopology (nsphere n) {x. 0 \ x k}) {x. x k = 0} r" apply (subst hom_induced_compose [symmetric]) using continuous_map_nsphere_reflection apply (force simp: r_def)+ done also have "\ = ?k" apply (subst hom_induced_compose [symmetric]) apply (simp_all add: image_subset_iff cmr) using hmrs homeomorphic_imp_continuous_map apply blast done finally show "?h \ ?g \ ?f = ?k" . qed with iso_relative_homology_group_upper_hemisphere [of p n k] have "h \ hom_induced p (subtopology (nsphere n) {f. 0 \ f k}) {f. f k = 0} (nsphere n) {f. f k \ 0} id \ f \ Group.iso ?G (relative_homology_group p (nsphere n) {f. 0 \ f k})" using f h iso_set_trans by blast then show ?thesis by (simp add: eq) qed lemma iso_lower_hemisphere_reduced_homology_group: "hom_boundary (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \ 0}) {x. x(Suc n) = 0} \ iso (relative_homology_group (1 + p) (subtopology (nsphere (Suc n)) {x. x(Suc n) \ 0}) {x. x(Suc n) = 0}) (reduced_homology_group p (nsphere n))" proof - have "{x. (\i\n. (x i)\<^sup>2) = 1 \ (\i>n. x i = 0)} = ({x. (\i\n. (x i)\<^sup>2) + (x (Suc n))\<^sup>2 = 1 \ (\i>Suc n. x i = 0)} \ {x. x (Suc n) \ 0} \ {x. x (Suc n) = (0::real)})" by (force simp: dest: Suc_lessI) then have n: "nsphere n = subtopology (subtopology (nsphere (Suc n)) {x. x(Suc n) \ 0}) {x. x(Suc n) = 0}" by (simp add: nsphere subtopology_subtopology) have ne: "(\i. if i = n then 1 else 0) \ topspace (subtopology (nsphere (Suc n)) {x. x (Suc n) \ 0}) \ {x. x (Suc n) = 0}" by (simp add: nsphere if_distrib [of "\x. x ^ 2"] cong: if_cong) show ?thesis unfolding n apply (rule iso_relative_homology_of_contractible [where p = "1 + p", simplified]) using contractible_space_lower_hemisphere ne apply blast+ done qed lemma isomorphism_sym: "\f \ iso G1 G2; \x. x \ carrier G1 \ r'(f x) = f(r x); \x. x \ carrier G1 \ r x \ carrier G1; group G1; group G2\ \ \f \ iso G2 G1. \x \ carrier G2. r(f x) = f(r' x)" apply (clarsimp simp add: group.iso_iff_group_isomorphisms Bex_def) by (metis (full_types) group_isomorphisms_def group_isomorphisms_sym hom_in_carrier) lemma isomorphism_trans: "\\f \ iso G1 G2. \x \ carrier G1. r2(f x) = f(r1 x); \f \ iso G2 G3. \x \ carrier G2. r3(f x) = f(r2 x)\ \ \f \ iso G1 G3. \x \ carrier G1. r3(f x) = f(r1 x)" apply clarify apply (rename_tac g f) apply (rule_tac x="f \ g" in bexI) apply (metis iso_iff comp_apply hom_in_carrier) using iso_set_trans by blast lemma reduced_homology_group_nsphere_step: "\f \ iso(reduced_homology_group p (nsphere n)) (reduced_homology_group (1 + p) (nsphere (Suc n))). \c \ carrier(reduced_homology_group p (nsphere n)). hom_induced (1 + p) (nsphere(Suc n)) {} (nsphere(Suc n)) {} (\x i. if i = 0 then -x i else x i) (f c) = f (hom_induced p (nsphere n) {} (nsphere n) {} (\x i. if i = 0 then -x i else x i) c)" proof - define r where "r \ \x::nat\real. \i. if i = 0 then -x i else x i" have cmr: "continuous_map (nsphere n) (nsphere n) r" for n unfolding r_def by (rule continuous_map_nsphere_reflection) have rsub: "r ` {x. 0 \ x (Suc n)} \ {x. 0 \ x (Suc n)}" "r ` {x. x (Suc n) \ 0} \ {x. x (Suc n) \ 0}" "r ` {x. x (Suc n) = 0} \ {x. x (Suc n) = 0}" by (force simp: r_def)+ let ?sub = "subtopology (nsphere (Suc n)) {x. x (Suc n) \ 0}" let ?G2 = "relative_homology_group (1 + p) ?sub {x. x (Suc n) = 0}" let ?r2 = "hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r" let ?j = "\p n. hom_induced p (nsphere n) {} (nsphere n) {} r" show ?thesis unfolding r_def [symmetric] proof (rule isomorphism_trans) let ?f = "hom_boundary (1 + p) ?sub {x. x (Suc n) = 0}" show "\f\Group.iso (reduced_homology_group p (nsphere n)) ?G2. \c\carrier (reduced_homology_group p (nsphere n)). ?r2 (f c) = f (?j p n c)" proof (rule isomorphism_sym) show "?f \ Group.iso ?G2 (reduced_homology_group p (nsphere n))" using iso_upper_hemisphere_reduced_homology_group by (metis add.commute) next fix c assume "c \ carrier ?G2" have cmrs: "continuous_map ?sub ?sub r" by (metis (mono_tags, lifting) IntE cmr continuous_map_from_subtopology continuous_map_in_subtopology image_subset_iff rsub(1) topspace_subtopology) have "hom_induced p (nsphere n) {} (nsphere n) {} r \ hom_boundary (1 + p) ?sub {x. x (Suc n) = 0} = hom_boundary (1 + p) ?sub {x. x (Suc n) = 0} \ hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r" using naturality_hom_induced [OF cmrs rsub(3), symmetric, of "1+p", simplified] by (simp add: subtopology_subtopology subtopology_nsphere_equator flip: Collect_conj_eq cong: rev_conj_cong) then show "?j p n (?f c) = ?f (hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r c)" by (metis comp_def) next fix c assume "c \ carrier ?G2" show "hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r c \ carrier ?G2" using hom_induced_carrier by blast qed auto next let ?H2 = "relative_homology_group (1 + p) (nsphere (Suc n)) {x. x (Suc n) \ 0}" let ?s2 = "hom_induced (1 + p) (nsphere (Suc n)) {x. x (Suc n) \ 0} (nsphere (Suc n)) {x. x (Suc n) \ 0} r" show "\f\Group.iso ?G2 (reduced_homology_group (1 + p) (nsphere (Suc n))). \c\carrier ?G2. ?j (1 + p) (Suc n) (f c) = f (?r2 c)" proof (rule isomorphism_trans) show "\f\Group.iso ?G2 ?H2. \c\carrier ?G2. ?s2 (f c) = f (hom_induced (1 + p) ?sub {x. x (Suc n) = 0} ?sub {x. x (Suc n) = 0} r c)" proof (intro ballI bexI) fix c assume "c \ carrier (relative_homology_group (1 + p) ?sub {x. x (Suc n) = 0})" show "?s2 (hom_induced (1 + p) ?sub {x. x (Suc n) = 0} (nsphere (Suc n)) {x. x (Suc n) \ 0} id c) = hom_induced (1 + p) ?sub {x. x (Suc n) = 0} (nsphere (Suc n)) {x. x (Suc n) \ 0} id (?r2 c)" apply (simp add: rsub hom_induced_compose' Collect_mono_iff cmr) apply (subst hom_induced_compose') apply (simp_all add: continuous_map_in_subtopology continuous_map_from_subtopology [OF cmr] rsub) apply (auto simp: r_def) done qed (simp add: iso_relative_homology_group_upper_hemisphere) next let ?h = "hom_induced (1 + p) (nsphere(Suc n)) {} (nsphere (Suc n)) {x. x(Suc n) \ 0} id" show "\f\Group.iso ?H2 (reduced_homology_group (1 + p) (nsphere (Suc n))). \c\carrier ?H2. ?j (1 + p) (Suc n) (f c) = f (?s2 c)" proof (rule isomorphism_sym) show "?h \ Group.iso (reduced_homology_group (1 + p) (nsphere (Suc n))) (relative_homology_group (1 + p) (nsphere (Suc n)) {x. x (Suc n) \ 0})" using iso_reduced_homology_group_lower_hemisphere by blast next fix c assume "c \ carrier (reduced_homology_group (1 + p) (nsphere (Suc n)))" show "?s2 (?h c) = ?h (?j (1 + p) (Suc n) c)" by (simp add: hom_induced_compose' cmr rsub) next fix c assume "c \ carrier (reduced_homology_group (1 + p) (nsphere (Suc n)))" then show "hom_induced (1 + p) (nsphere (Suc n)) {} (nsphere (Suc n)) {} r c \ carrier (reduced_homology_group (1 + p) (nsphere (Suc n)))" by (simp add: hom_induced_reduced) qed auto qed qed qed lemma reduced_homology_group_nsphere_aux: "if p = int n then reduced_homology_group n (nsphere n) \ integer_group else trivial_group(reduced_homology_group p (nsphere n))" proof (induction n arbitrary: p) case 0 let ?a = "\i::nat. if i = 0 then 1 else (0::real)" let ?b = "\i::nat. if i = 0 then -1 else (0::real)" have st: "subtopology (powertop_real UNIV) {?a, ?b} = nsphere 0" proof - have "{?a, ?b} = {x. (x 0)\<^sup>2 = 1 \ (\i>0. x i = 0)}" using power2_eq_iff by fastforce then show ?thesis by (simp add: nsphere) qed have *: "reduced_homology_group p (subtopology (powertop_real UNIV) {?a, ?b}) \ homology_group p (subtopology (powertop_real UNIV) {?a})" apply (rule reduced_homology_group_pair) apply (simp_all add: fun_eq_iff) apply (simp add: open_fun_def separation_t1 t1_space_def) done have "reduced_homology_group 0 (nsphere 0) \ integer_group" if "p=0" proof - have "reduced_homology_group 0 (nsphere 0) \ homology_group 0 (top_of_set {?a})" if "p=0" by (metis * euclidean_product_topology st that) also have "\ \ integer_group" by (simp add: homology_coefficients) finally show ?thesis using that by blast qed moreover have "trivial_group (reduced_homology_group p (nsphere 0))" if "p\0" using * that homology_dimension_axiom [of "subtopology (powertop_real UNIV) {?a}" ?a p] using isomorphic_group_triviality st by force ultimately show ?case by auto next case (Suc n) have eq: "reduced_homology_group (int n) (nsphere n) \ integer_group" if "p-1 = n" by (simp add: Suc.IH) have neq: "trivial_group (reduced_homology_group (p-1) (nsphere n))" if "p-1 \ n" by (simp add: Suc.IH that) have iso: "reduced_homology_group p (nsphere (Suc n)) \ reduced_homology_group (p-1) (nsphere n)" using reduced_homology_group_nsphere_step [of "p-1" n] group.iso_sym [OF _ is_isoI] group_reduced_homology_group by fastforce then show ?case using eq iso_trans iso isomorphic_group_triviality neq by (metis (no_types, hide_lams) add.commute add_left_cancel diff_add_cancel group_reduced_homology_group of_nat_Suc) qed lemma reduced_homology_group_nsphere: "reduced_homology_group n (nsphere n) \ integer_group" "p \ n \ trivial_group(reduced_homology_group p (nsphere n))" using reduced_homology_group_nsphere_aux by auto lemma cyclic_reduced_homology_group_nsphere: "cyclic_group(reduced_homology_group p (nsphere n))" by (metis reduced_homology_group_nsphere trivial_imp_cyclic_group cyclic_integer_group group_integer_group group_reduced_homology_group isomorphic_group_cyclicity) lemma trivial_reduced_homology_group_nsphere: "trivial_group(reduced_homology_group p (nsphere n)) \ (p \ n)" using group_integer_group isomorphic_group_triviality nontrivial_integer_group reduced_homology_group_nsphere(1) reduced_homology_group_nsphere(2) trivial_group_def by blast lemma non_contractible_space_nsphere: "\ (contractible_space(nsphere n))" proof (clarsimp simp add: contractible_eq_homotopy_equivalent_singleton_subtopology) fix a :: "nat \ real" assume a: "a \ topspace (nsphere n)" and he: "nsphere n homotopy_equivalent_space subtopology (nsphere n) {a}" have "trivial_group (reduced_homology_group (int n) (subtopology (nsphere n) {a}))" by (simp add: a homology_dimension_reduced [where a=a]) then show "False" using isomorphic_group_triviality [OF homotopy_equivalent_space_imp_isomorphic_reduced_homology_groups [OF he, of n]] by (simp add: trivial_reduced_homology_group_nsphere) qed subsection\Brouwer degree of a Map\ definition Brouwer_degree2 :: "nat \ ((nat \ real) \ nat \ real) \ int" where "Brouwer_degree2 p f \ @d::int. \x \ carrier(reduced_homology_group p (nsphere p)). hom_induced p (nsphere p) {} (nsphere p) {} f x = pow (reduced_homology_group p (nsphere p)) x d" lemma Brouwer_degree2_eq: "(\x. x \ topspace(nsphere p) \ f x = g x) \ Brouwer_degree2 p f = Brouwer_degree2 p g" unfolding Brouwer_degree2_def Ball_def apply (intro Eps_cong all_cong) by (metis (mono_tags, lifting) hom_induced_eq) lemma Brouwer_degree2: assumes "x \ carrier(reduced_homology_group p (nsphere p))" shows "hom_induced p (nsphere p) {} (nsphere p) {} f x = pow (reduced_homology_group p (nsphere p)) x (Brouwer_degree2 p f)" (is "?h x = pow ?G x _") proof (cases "continuous_map(nsphere p) (nsphere p) f") case True interpret group ?G by simp interpret group_hom ?G ?G ?h using hom_induced_reduced_hom group_hom_axioms_def group_hom_def is_group by blast obtain a where a: "a \ carrier ?G" and aeq: "subgroup_generated ?G {a} = ?G" using cyclic_reduced_homology_group_nsphere [of p p] by (auto simp: cyclic_group_def) then have carra: "carrier (subgroup_generated ?G {a}) = range (\n::int. pow ?G a n)" using carrier_subgroup_generated_by_singleton by blast moreover have "?h a \ carrier (subgroup_generated ?G {a})" by (simp add: a aeq hom_induced_reduced) ultimately obtain d::int where d: "?h a = pow ?G a d" by auto have *: "hom_induced (int p) (nsphere p) {} (nsphere p) {} f x = x [^]\<^bsub>?G\<^esub> d" if x: "x \ carrier ?G" for x proof - obtain n::int where xeq: "x = pow ?G a n" using carra x aeq by moura show ?thesis by (simp add: xeq a d hom_int_pow int_pow_pow mult.commute) qed show ?thesis unfolding Brouwer_degree2_def apply (rule someI2 [where a=d]) using assms * apply blast+ done next case False show ?thesis unfolding Brouwer_degree2_def by (rule someI2 [where a=0]) (simp_all add: hom_induced_default False one_reduced_homology_group assms) qed lemma Brouwer_degree2_iff: assumes f: "continuous_map (nsphere p) (nsphere p) f" and x: "x \ carrier(reduced_homology_group p (nsphere p))" shows "(hom_induced (int p) (nsphere p) {} (nsphere p) {} f x = x [^]\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> d) \ (x = \\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> \ Brouwer_degree2 p f = d)" (is "(?h x = x [^]\<^bsub>?G\<^esub> d) \ _") proof - interpret group "?G" by simp obtain a where a: "a \ carrier ?G" and aeq: "subgroup_generated ?G {a} = ?G" using cyclic_reduced_homology_group_nsphere [of p p] by (auto simp: cyclic_group_def) then obtain i::int where i: "x = (a [^]\<^bsub>?G\<^esub> i)" using carrier_subgroup_generated_by_singleton x by fastforce then have "a [^]\<^bsub>?G\<^esub> i \ carrier ?G" using x by blast have [simp]: "ord a = 0" by (simp add: a aeq iso_finite [OF reduced_homology_group_nsphere(1)] flip: infinite_cyclic_subgroup_order) show ?thesis by (auto simp: Brouwer_degree2 int_pow_eq_id x i a int_pow_pow int_pow_eq) qed lemma Brouwer_degree2_unique: assumes f: "continuous_map (nsphere p) (nsphere p) f" and hi: "\x. x \ carrier(reduced_homology_group p (nsphere p)) \ hom_induced p (nsphere p) {} (nsphere p) {} f x = pow (reduced_homology_group p (nsphere p)) x d" (is "\x. x \ carrier ?G \ ?h x = _") shows "Brouwer_degree2 p f = d" proof - obtain a where a: "a \ carrier ?G" and aeq: "subgroup_generated ?G {a} = ?G" using cyclic_reduced_homology_group_nsphere [of p p] by (auto simp: cyclic_group_def) show ?thesis using hi [OF a] apply (simp add: Brouwer_degree2 a) by (metis Brouwer_degree2_iff a aeq f group.trivial_group_subgroup_generated group_reduced_homology_group subsetI trivial_reduced_homology_group_nsphere) qed lemma Brouwer_degree2_unique_generator: assumes f: "continuous_map (nsphere p) (nsphere p) f" and eq: "subgroup_generated (reduced_homology_group p (nsphere p)) {a} = reduced_homology_group p (nsphere p)" and hi: "hom_induced p (nsphere p) {} (nsphere p) {} f a = pow (reduced_homology_group p (nsphere p)) a d" (is "?h a = pow ?G a _") shows "Brouwer_degree2 p f = d" proof (cases "a \ carrier ?G") case True then show ?thesis by (metis Brouwer_degree2_iff hi eq f group.trivial_group_subgroup_generated group_reduced_homology_group subset_singleton_iff trivial_reduced_homology_group_nsphere) next case False then show ?thesis using trivial_reduced_homology_group_nsphere [of p p] by (metis group.trivial_group_subgroup_generated_eq disjoint_insert(1) eq group_reduced_homology_group inf_bot_right subset_singleton_iff) qed lemma Brouwer_degree2_homotopic: assumes "homotopic_with (\x. True) (nsphere p) (nsphere p) f g" shows "Brouwer_degree2 p f = Brouwer_degree2 p g" proof - have "continuous_map (nsphere p) (nsphere p) f" using homotopic_with_imp_continuous_maps [OF assms] by auto show ?thesis using Brouwer_degree2_def assms homology_homotopy_empty by fastforce qed lemma Brouwer_degree2_id [simp]: "Brouwer_degree2 p id = 1" proof (rule Brouwer_degree2_unique) fix x assume x: "x \ carrier (reduced_homology_group (int p) (nsphere p))" then have "x \ carrier (homology_group (int p) (nsphere p))" using carrier_reduced_homology_group_subset by blast then show "hom_induced (int p) (nsphere p) {} (nsphere p) {} id x = x [^]\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> (1::int)" by (simp add: hom_induced_id group.int_pow_1 x) qed auto lemma Brouwer_degree2_compose: assumes f: "continuous_map (nsphere p) (nsphere p) f" and g: "continuous_map (nsphere p) (nsphere p) g" shows "Brouwer_degree2 p (g \ f) = Brouwer_degree2 p g * Brouwer_degree2 p f" proof (rule Brouwer_degree2_unique) show "continuous_map (nsphere p) (nsphere p) (g \ f)" by (meson continuous_map_compose f g) next fix x assume x: "x \ carrier (reduced_homology_group (int p) (nsphere p))" have "hom_induced (int p) (nsphere p) {} (nsphere p) {} (g \ f) = hom_induced (int p) (nsphere p) {} (nsphere p) {} g \ hom_induced (int p) (nsphere p) {} (nsphere p) {} f" by (blast intro: hom_induced_compose [OF f _ g]) with x show "hom_induced (int p) (nsphere p) {} (nsphere p) {} (g \ f) x = x [^]\<^bsub>reduced_homology_group (int p) (nsphere p)\<^esub> (Brouwer_degree2 p g * Brouwer_degree2 p f)" by (simp add: mult.commute hom_induced_reduced flip: Brouwer_degree2 group.int_pow_pow) qed lemma Brouwer_degree2_homotopy_equivalence: assumes f: "continuous_map (nsphere p) (nsphere p) f" and g: "continuous_map (nsphere p) (nsphere p) g" and hom: "homotopic_with (\x. True) (nsphere p) (nsphere p) (f \ g) id" obtains "\Brouwer_degree2 p f\ = 1" "\Brouwer_degree2 p g\ = 1" "Brouwer_degree2 p g = Brouwer_degree2 p f" using Brouwer_degree2_homotopic [OF hom] Brouwer_degree2_compose f g zmult_eq_1_iff by auto lemma Brouwer_degree2_homeomorphic_maps: assumes "homeomorphic_maps (nsphere p) (nsphere p) f g" obtains "\Brouwer_degree2 p f\ = 1" "\Brouwer_degree2 p g\ = 1" "Brouwer_degree2 p g = Brouwer_degree2 p f" using assms by (auto simp: homeomorphic_maps_def homotopic_with_equal continuous_map_compose intro: Brouwer_degree2_homotopy_equivalence) lemma Brouwer_degree2_retraction_map: assumes "retraction_map (nsphere p) (nsphere p) f" shows "\Brouwer_degree2 p f\ = 1" proof - obtain g where g: "retraction_maps (nsphere p) (nsphere p) f g" using assms by (auto simp: retraction_map_def) show ?thesis proof (rule Brouwer_degree2_homotopy_equivalence) show "homotopic_with (\x. True) (nsphere p) (nsphere p) (f \ g) id" using g apply (auto simp: retraction_maps_def) by (simp add: homotopic_with_equal continuous_map_compose) show "continuous_map (nsphere p) (nsphere p) f" "continuous_map (nsphere p) (nsphere p) g" using g retraction_maps_def by blast+ qed qed lemma Brouwer_degree2_section_map: assumes "section_map (nsphere p) (nsphere p) f" shows "\Brouwer_degree2 p f\ = 1" proof - obtain g where g: "retraction_maps (nsphere p) (nsphere p) g f" using assms by (auto simp: section_map_def) show ?thesis proof (rule Brouwer_degree2_homotopy_equivalence) show "homotopic_with (\x. True) (nsphere p) (nsphere p) (g \ f) id" using g apply (auto simp: retraction_maps_def) by (simp add: homotopic_with_equal continuous_map_compose) show "continuous_map (nsphere p) (nsphere p) g" "continuous_map (nsphere p) (nsphere p) f" using g retraction_maps_def by blast+ qed qed lemma Brouwer_degree2_homeomorphic_map: "homeomorphic_map (nsphere p) (nsphere p) f \ \Brouwer_degree2 p f\ = 1" using Brouwer_degree2_retraction_map section_and_retraction_eq_homeomorphic_map by blast lemma Brouwer_degree2_nullhomotopic: assumes "homotopic_with (\x. True) (nsphere p) (nsphere p) f (\x. a)" shows "Brouwer_degree2 p f = 0" proof - have contf: "continuous_map (nsphere p) (nsphere p) f" and contc: "continuous_map (nsphere p) (nsphere p) (\x. a)" using homotopic_with_imp_continuous_maps [OF assms] by metis+ have "Brouwer_degree2 p f = Brouwer_degree2 p (\x. a)" using Brouwer_degree2_homotopic [OF assms] . moreover let ?G = "reduced_homology_group (int p) (nsphere p)" interpret group ?G by simp have "Brouwer_degree2 p (\x. a) = 0" proof (rule Brouwer_degree2_unique [OF contc]) fix c assume c: "c \ carrier ?G" have "continuous_map (nsphere p) (subtopology (nsphere p) {a}) (\f. a)" using contc continuous_map_in_subtopology by blast then have he: "hom_induced p (nsphere p) {} (nsphere p) {} (\x. a) = hom_induced p (subtopology (nsphere p) {a}) {} (nsphere p) {} id \ hom_induced p (nsphere p) {} (subtopology (nsphere p) {a}) {} (\x. a)" by (metis continuous_map_id_subt hom_induced_compose id_comp image_empty order_refl) have 1: "hom_induced p (nsphere p) {} (subtopology (nsphere p) {a}) {} (\x. a) c = \\<^bsub>reduced_homology_group (int p) (subtopology (nsphere p) {a})\<^esub>" using c trivial_reduced_homology_group_contractible_space [of "subtopology (nsphere p) {a}" p] by (simp add: hom_induced_reduced contractible_space_subtopology_singleton trivial_group_subset group.trivial_group_subset subset_iff) show "hom_induced (int p) (nsphere p) {} (nsphere p) {} (\x. a) c = c [^]\<^bsub>?G\<^esub> (0::int)" apply (simp add: he 1) using hom_induced_reduced_hom group_hom.hom_one group_hom_axioms_def group_hom_def group_reduced_homology_group by blast qed ultimately show ?thesis by metis qed lemma Brouwer_degree2_const: "Brouwer_degree2 p (\x. a) = 0" proof (cases "continuous_map(nsphere p) (nsphere p) (\x. a)") case True then show ?thesis by (auto intro: Brouwer_degree2_nullhomotopic [where a=a]) next case False let ?G = "reduced_homology_group (int p) (nsphere p)" let ?H = "homology_group (int p) (nsphere p)" interpret group ?G by simp have eq1: "\\<^bsub>?H\<^esub> = \\<^bsub>?G\<^esub>" by (simp add: one_reduced_homology_group) have *: "\x\carrier ?G. hom_induced (int p) (nsphere p) {} (nsphere p) {} (\x. a) x = \\<^bsub>?H\<^esub>" by (metis False hom_induced_default one_relative_homology_group) obtain c where c: "c \ carrier ?G" and ceq: "subgroup_generated ?G {c} = ?G" using cyclic_reduced_homology_group_nsphere [of p p] by (force simp: cyclic_group_def) have [simp]: "ord c = 0" by (simp add: c ceq iso_finite [OF reduced_homology_group_nsphere(1)] flip: infinite_cyclic_subgroup_order) show ?thesis unfolding Brouwer_degree2_def proof (rule some_equality) fix d :: "int" assume "\x\carrier ?G. hom_induced (int p) (nsphere p) {} (nsphere p) {} (\x. a) x = x [^]\<^bsub>?G\<^esub> d" then have "c [^]\<^bsub>?G\<^esub> d = \\<^bsub>?H\<^esub>" using "*" c by blast then have "int (ord c) dvd d" using c eq1 int_pow_eq_id by auto then show "d = 0" by (simp add: * del: one_relative_homology_group) qed (use "*" eq1 in force) qed corollary Brouwer_degree2_nonsurjective: "\continuous_map(nsphere p) (nsphere p) f; f ` topspace (nsphere p) \ topspace (nsphere p)\ \ Brouwer_degree2 p f = 0" by (meson Brouwer_degree2_nullhomotopic nullhomotopic_nonsurjective_sphere_map) proposition Brouwer_degree2_reflection: "Brouwer_degree2 p (\x i. if i = 0 then -x i else x i) = -1" (is "Brouwer_degree2 _ ?r = -1") proof (induction p) case 0 let ?G = "homology_group 0 (nsphere 0)" let ?D = "homology_group 0 (discrete_topology {()})" interpret group ?G by simp define r where "r \ \x::nat\real. \i. if i = 0 then -x i else x i" then have [simp]: "r \ r = id" by force have cmr: "continuous_map (nsphere 0) (nsphere 0) r" by (simp add: r_def continuous_map_nsphere_reflection) have *: "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r c = inv\<^bsub>?G\<^esub> c" if "c \ carrier(reduced_homology_group 0 (nsphere 0))" for c proof - have c: "c \ carrier ?G" and ceq: "hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\x. ()) c = \\<^bsub>?D\<^esub>" using that by (auto simp: carrier_reduced_homology_group kernel_def) define pp::"nat\real" where "pp \ \i. if i = 0 then 1 else 0" define nn::"nat\real" where "nn \ \i. if i = 0 then -1 else 0" have topn0: "topspace(nsphere 0) = {pp,nn}" by (auto simp: nsphere pp_def nn_def fun_eq_iff power2_eq_1_iff split: if_split_asm) have "t1_space (nsphere 0)" unfolding nsphere apply (rule t1_space_subtopology) by (metis (full_types) open_fun_def t1_space t1_space_def) then have dtn0: "discrete_topology {pp,nn} = nsphere 0" using finite_t1_space_imp_discrete_topology [OF topn0] by auto have "pp \ nn" by (auto simp: pp_def nn_def fun_eq_iff) have [simp]: "r pp = nn" "r nn = pp" by (auto simp: r_def pp_def nn_def fun_eq_iff) have iso: "(\(a,b). hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id a \\<^bsub>?G\<^esub> hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id b) \ iso (homology_group 0 (subtopology (nsphere 0) {pp}) \\ homology_group 0 (subtopology (nsphere 0) {nn})) ?G" (is "?f \ iso (?P \\ ?N) ?G") apply (rule homology_additivity_explicit) using dtn0 \pp \ nn\ by (auto simp: discrete_topology_unique) then have fim: "?f ` carrier(?P \\ ?N) = carrier ?G" by (simp add: iso_def bij_betw_def) obtain d d' where d: "d \ carrier ?P" and d': "d' \ carrier ?N" and eqc: "?f(d,d') = c" using c by (force simp flip: fim) let ?h = "\xx. hom_induced 0 (subtopology (nsphere 0) {xx}) {} (discrete_topology {()}) {} (\x. ())" have "retraction_map (subtopology (nsphere 0) {pp}) (subtopology (nsphere 0) {nn}) r" apply (simp add: retraction_map_def retraction_maps_def continuous_map_in_subtopology continuous_map_from_subtopology cmr image_subset_iff) apply (rule_tac x=r in exI) apply (force simp: retraction_map_def retraction_maps_def continuous_map_in_subtopology continuous_map_from_subtopology cmr) done then have "carrier ?N = (hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r) ` carrier ?P" by (rule surj_hom_induced_retraction_map) then obtain e where e: "e \ carrier ?P" and eqd': "hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r e = d'" using d' by auto have "section_map (subtopology (nsphere 0) {pp}) (discrete_topology {()}) (\x. ())" by (force simp: section_map_def retraction_maps_def topn0) then have "?h pp \ mon ?P ?D" by (rule mon_hom_induced_section_map) then have one: "x = one ?P" if "?h pp x = \\<^bsub>?D\<^esub>" "x \ carrier ?P" for x using that by (simp add: mon_iff_hom_one) interpret hpd: group_hom ?P ?D "?h pp" using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def) interpret hgd: group_hom ?G ?D "hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\x. ())" using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def) interpret hpg: group_hom ?P ?G "hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r" using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def) interpret hgg: group_hom ?G ?G "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r" using hom_induced_empty_hom by (simp add: hom_induced_empty_hom group_hom_axioms_def group_hom_def) have "?h pp d = (hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\x. ()) \ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id) d" by (simp flip: hom_induced_compose_empty) moreover have "?h pp = ?h nn \ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r" by (simp add: cmr continuous_map_from_subtopology continuous_map_in_subtopology image_subset_iff flip: hom_induced_compose_empty) then have "?h pp e = (hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\x. ()) \ hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id) d'" by (simp flip: hom_induced_compose_empty eqd') ultimately have "?h pp (d \\<^bsub>?P\<^esub> e) = hom_induced 0 (nsphere 0) {} (discrete_topology {()}) {} (\x. ()) (?f(d,d'))" by (simp add: d e hom_induced_carrier) then have "?h pp (d \\<^bsub>?P\<^esub> e) = \\<^bsub>?D\<^esub>" using ceq eqc by simp then have inv_p: "inv\<^bsub>?P\<^esub> d = e" by (metis (no_types, lifting) Group.group_def d e group.inv_equality group.r_inv group_relative_homology_group one monoid.m_closed) have cmr_pn: "continuous_map (subtopology (nsphere 0) {pp}) (subtopology (nsphere 0) {nn}) r" by (simp add: cmr continuous_map_from_subtopology continuous_map_in_subtopology image_subset_iff) then have "hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} (id \ r) = hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id \ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (subtopology (nsphere 0) {nn}) {} r" using hom_induced_compose_empty continuous_map_id_subt by blast then have "inv\<^bsub>?G\<^esub> hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r d = hom_induced 0 (subtopology (nsphere 0) {nn}) {} (nsphere 0) {} id d'" apply (simp add: flip: inv_p eqd') using d hpg.hom_inv by auto then have c: "c = (hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id d) \\<^bsub>?G\<^esub> inv\<^bsub>?G\<^esub> (hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r d)" by (simp flip: eqc) have "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r \ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id = hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r" by (metis cmr comp_id continuous_map_id_subt hom_induced_compose_empty) moreover have "hom_induced 0 (nsphere 0) {} (nsphere 0) {} r \ hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} r = hom_induced 0 (subtopology (nsphere 0) {pp}) {} (nsphere 0) {} id" by (metis \r \ r = id\ cmr continuous_map_from_subtopology hom_induced_compose_empty) ultimately show ?thesis by (metis inv_p c comp_def d e hgg.hom_inv hgg.hom_mult hom_induced_carrier hpd.G.inv_inv hpg.hom_inv inv_mult_group) qed show ?case unfolding r_def [symmetric] using Brouwer_degree2_unique [OF cmr] by (auto simp: * group.int_pow_neg group.int_pow_1 reduced_homology_group_def intro!: Brouwer_degree2_unique [OF cmr]) next case (Suc p) let ?G = "reduced_homology_group (int p) (nsphere p)" let ?G1 = "reduced_homology_group (1 + int p) (nsphere (Suc p))" obtain f g where fg: "group_isomorphisms ?G ?G1 f g" and *: "\c\carrier ?G. hom_induced (1 + int p) (nsphere (Suc p)) {} (nsphere (Suc p)) {} ?r (f c) = f (hom_induced p (nsphere p) {} (nsphere p) {} ?r c)" using reduced_homology_group_nsphere_step by (meson group.iso_iff_group_isomorphisms group_reduced_homology_group) then have eq: "carrier ?G1 = f ` carrier ?G" by (fastforce simp add: iso_iff dest: group_isomorphisms_imp_iso) interpret group_hom ?G ?G1 f by (meson fg group_hom_axioms_def group_hom_def group_isomorphisms_def group_reduced_homology_group) have homf: "f \ hom ?G ?G1" using fg group_isomorphisms_def by blast have "hom_induced (1 + int p) (nsphere (Suc p)) {} (nsphere (Suc p)) {} ?r (f y) = f y [^]\<^bsub>?G1\<^esub> (-1::int)" if "y \ carrier ?G" for y by (simp add: that * Brouwer_degree2 Suc hom_int_pow) then show ?case by (fastforce simp: eq intro: Brouwer_degree2_unique [OF continuous_map_nsphere_reflection]) qed end