diff --git a/metadata/metadata b/metadata/metadata --- a/metadata/metadata +++ b/metadata/metadata @@ -1,9496 +1,9581 @@ [Arith_Prog_Rel_Primes] title = Arithmetic progressions and relative primes author = José Manuel Rodríguez Caballero topic = Mathematics/Number theory date = 2020-02-01 notify = jose.manuel.rodriguez.caballero@ut.ee abstract = This article provides a formalization of the solution obtained by the author of the Problem “ARITHMETIC PROGRESSIONS” from the Putnam exam problems of 2002. The statement of the problem is as follows: For which integers n > 1 does the set of positive integers less than and relatively prime to n constitute an arithmetic progression? [Banach_Steinhaus] title = Banach-Steinhaus Theorem author = Dominique Unruh , Jose Manuel Rodriguez Caballero topic = Mathematics/Analysis date = 2020-05-02 notify = jose.manuel.rodriguez.caballero@ut.ee, unruh@ut.ee abstract = We formalize in Isabelle/HOL a result due to S. Banach and H. Steinhaus known as the Banach-Steinhaus theorem or Uniform boundedness principle: a pointwise-bounded family of continuous linear operators from a Banach space to a normed space is uniformly bounded. Our approach is an adaptation to Isabelle/HOL of a proof due to A. Sokal. [Complex_Geometry] title = Complex Geometry author = Filip Marić , Danijela Simić topic = Mathematics/Geometry date = 2019-12-16 notify = danijela@matf.bg.ac.rs, filip@matf.bg.ac.rs, boutry@unistra.fr abstract = A formalization of geometry of complex numbers is presented. Fundamental objects that are investigated are the complex plane extended by a single infinite point, its objects (points, lines and circles), and groups of transformations that act on them (e.g., inversions and Möbius transformations). Most objects are defined algebraically, but correspondence with classical geometric definitions is shown. [Poincare_Disc] title = Poincaré Disc Model author = Danijela Simić , Filip Marić , Pierre Boutry topic = Mathematics/Geometry date = 2019-12-16 notify = danijela@matf.bg.ac.rs, filip@matf.bg.ac.rs, boutry@unistra.fr abstract = We describe formalization of the Poincaré disc model of hyperbolic geometry within the Isabelle/HOL proof assistant. The model is defined within the extended complex plane (one dimensional complex projectives space ℂP1), formalized in the AFP entry “Complex Geometry”. Points, lines, congruence of pairs of points, betweenness of triples of points, circles, and isometries are defined within the model. It is shown that the model satisfies all Tarski's axioms except the Euclid's axiom. It is shown that it satisfies its negation and the limiting parallels axiom (which proves it to be a model of hyperbolic geometry). [Fourier] title = Fourier Series author = Lawrence C Paulson topic = Mathematics/Analysis date = 2019-09-06 notify = lp15@cam.ac.uk abstract = This development formalises the square integrable functions over the reals and the basics of Fourier series. It culminates with a proof that every well-behaved periodic function can be approximated by a Fourier series. The material is ported from HOL Light: https://github.com/jrh13/hol-light/blob/master/100/fourier.ml [Generic_Deriving] title = Deriving generic class instances for datatypes author = Jonas Rädle , Lars Hupel topic = Computer science/Data structures date = 2018-11-06 notify = jonas.raedle@gmail.com abstract =

We provide a framework for automatically deriving instances for generic type classes. Our approach is inspired by Haskell's generic-deriving package and Scala's shapeless library. In addition to generating the code for type class functions, we also attempt to automatically prove type class laws for these instances. As of now, however, some manual proofs are still required for recursive datatypes.

Note: There are already articles in the AFP that provide automatic instantiation for a number of classes. Concretely, Deriving allows the automatic instantiation of comparators, linear orders, equality, and hashing. Show instantiates a Haskell-style show class.

Our approach works for arbitrary classes (with some Isabelle/HOL overhead for each class), but a smaller set of datatypes.

[Partial_Order_Reduction] title = Partial Order Reduction author = Julian Brunner topic = Computer science/Automata and formal languages date = 2018-06-05 notify = brunnerj@in.tum.de abstract = This entry provides a formalization of the abstract theory of ample set partial order reduction. The formalization includes transition systems with actions, trace theory, as well as basics on finite, infinite, and lazy sequences. We also provide a basic framework for static analysis on concurrent systems with respect to the ample set condition. [CakeML] title = CakeML author = Lars Hupel , Yu Zhang <> contributors = Johannes Åman Pohjola <> topic = Computer science/Programming languages/Language definitions date = 2018-03-12 notify = hupel@in.tum.de abstract = CakeML is a functional programming language with a proven-correct compiler and runtime system. This entry contains an unofficial version of the CakeML semantics that has been exported from the Lem specifications to Isabelle. Additionally, there are some hand-written theory files that adapt the exported code to Isabelle and port proofs from the HOL4 formalization, e.g. termination and equivalence proofs. [CakeML_Codegen] title = A Verified Code Generator from Isabelle/HOL to CakeML author = Lars Hupel topic = Computer science/Programming languages/Compiling, Logic/Rewriting date = 2019-07-08 notify = lars@hupel.info abstract = This entry contains the formalization that accompanies my PhD thesis (see https://lars.hupel.info/research/codegen/). I develop a verified compilation toolchain from executable specifications in Isabelle/HOL to CakeML abstract syntax trees. This improves over the state-of-the-art in Isabelle by providing a trustworthy procedure for code generation. [DiscretePricing] title = Pricing in discrete financial models author = Mnacho Echenim topic = Mathematics/Probability theory, Mathematics/Games and economics date = 2018-07-16 notify = mnacho.echenim@univ-grenoble-alpes.fr abstract = We have formalized the computation of fair prices for derivative products in discrete financial models. As an application, we derive a way to compute fair prices of derivative products in the Cox-Ross-Rubinstein model of a financial market, thus completing the work that was presented in this paper. extra-history = Change history: [2019-05-12]: Renamed discr_mkt predicate to stk_strict_subs and got rid of predicate A for a more natural definition of the type discrete_market; renamed basic quantity processes for coherent notation; renamed value_process into val_process and closing_value_process to cls_val_process; relaxed hypothesis of lemma CRR_market_fair_price. Added functions to price some basic options. (revision 0b813a1a833f)
[Pell] title = Pell's Equation author = Manuel Eberl topic = Mathematics/Number theory date = 2018-06-23 notify = eberlm@in.tum.de abstract =

This article gives the basic theory of Pell's equation x2 = 1 + D y2, where D ∈ ℕ is a parameter and x, y are integer variables.

The main result that is proven is the following: If D is not a perfect square, then there exists a fundamental solution (x0, y0) that is not the trivial solution (1, 0) and which generates all other solutions (x, y) in the sense that there exists some n ∈ ℕ such that |x| + |y| √D = (x0 + y0 √D)n. This also implies that the set of solutions is infinite, and it gives us an explicit and executable characterisation of all the solutions.

Based on this, simple executable algorithms for computing the fundamental solution and the infinite sequence of all non-negative solutions are also provided.

[WebAssembly] title = WebAssembly author = Conrad Watt topic = Computer science/Programming languages/Language definitions date = 2018-04-29 notify = caw77@cam.ac.uk abstract = This is a mechanised specification of the WebAssembly language, drawn mainly from the previously published paper formalisation of Haas et al. Also included is a full proof of soundness of the type system, together with a verified type checker and interpreter. We include only a partial procedure for the extraction of the type checker and interpreter here. For more details, please see our paper in CPP 2018. [Knuth_Morris_Pratt] title = The string search algorithm by Knuth, Morris and Pratt author = Fabian Hellauer , Peter Lammich topic = Computer science/Algorithms date = 2017-12-18 notify = hellauer@in.tum.de, lammich@in.tum.de abstract = The Knuth-Morris-Pratt algorithm is often used to show that the problem of finding a string s in a text t can be solved deterministically in O(|s| + |t|) time. We use the Isabelle Refinement Framework to formulate and verify the algorithm. Via refinement, we apply some optimisations and finally use the Sepref tool to obtain executable code in Imperative/HOL. [Minkowskis_Theorem] title = Minkowski's Theorem author = Manuel Eberl topic = Mathematics/Geometry, Mathematics/Number theory date = 2017-07-13 notify = eberlm@in.tum.de abstract =

Minkowski's theorem relates a subset of ℝn, the Lebesgue measure, and the integer lattice ℤn: It states that any convex subset of ℝn with volume greater than 2n contains at least one lattice point from ℤn\{0}, i. e. a non-zero point with integer coefficients.

A related theorem which directly implies this is Blichfeldt's theorem, which states that any subset of ℝn with a volume greater than 1 contains two different points whose difference vector has integer components.

The entry contains a proof of both theorems.

[Name_Carrying_Type_Inference] title = Verified Metatheory and Type Inference for a Name-Carrying Simply-Typed Lambda Calculus author = Michael Rawson topic = Computer science/Programming languages/Type systems date = 2017-07-09 notify = mr644@cam.ac.uk, michaelrawson76@gmail.com abstract = I formalise a Church-style simply-typed \(\lambda\)-calculus, extended with pairs, a unit value, and projection functions, and show some metatheory of the calculus, such as the subject reduction property. Particular attention is paid to the treatment of names in the calculus. A nominal style of binding is used, but I use a manual approach over Nominal Isabelle in order to extract an executable type inference algorithm. More information can be found in my undergraduate dissertation. [Propositional_Proof_Systems] title = Propositional Proof Systems author = Julius Michaelis , Tobias Nipkow topic = Logic/Proof theory date = 2017-06-21 notify = maintainafpppt@liftm.de abstract = We formalize a range of proof systems for classical propositional logic (sequent calculus, natural deduction, Hilbert systems, resolution) and prove the most important meta-theoretic results about semantics and proofs: compactness, soundness, completeness, translations between proof systems, cut-elimination, interpolation and model existence. [Optics] title = Optics author = Simon Foster , Frank Zeyda topic = Computer science/Functional programming, Mathematics/Algebra date = 2017-05-25 notify = simon.foster@york.ac.uk abstract = Lenses provide an abstract interface for manipulating data types through spatially-separated views. They are defined abstractly in terms of two functions, get, the return a value from the source type, and put that updates the value. We mechanise the underlying theory of lenses, in terms of an algebraic hierarchy of lenses, including well-behaved and very well-behaved lenses, each lens class being characterised by a set of lens laws. We also mechanise a lens algebra in Isabelle that enables their composition and comparison, so as to allow construction of complex lenses. This is accompanied by a large library of algebraic laws. Moreover we also show how the lens classes can be applied by instantiating them with a number of Isabelle data types. extra-history = Change history: [2020-03-02]: Added partial bijective and symmetric lenses. Improved alphabet command generating additional lenses and results. Several additional lens relations, including observational equivalence. Additional theorems throughout. Adaptations for Isabelle 2020. (revision 44e2e5c) [Game_Based_Crypto] title = Game-based cryptography in HOL author = Andreas Lochbihler , S. Reza Sefidgar <>, Bhargav Bhatt topic = Computer science/Security/Cryptography date = 2017-05-05 notify = mail@andreas-lochbihler.de abstract =

In this AFP entry, we show how to specify game-based cryptographic security notions and formally prove secure several cryptographic constructions from the literature using the CryptHOL framework. Among others, we formalise the notions of a random oracle, a pseudo-random function, an unpredictable function, and of encryption schemes that are indistinguishable under chosen plaintext and/or ciphertext attacks. We prove the random-permutation/random-function switching lemma, security of the Elgamal and hashed Elgamal public-key encryption scheme and correctness and security of several constructions with pseudo-random functions.

Our proofs follow the game-hopping style advocated by Shoup and Bellare and Rogaway, from which most of the examples have been taken. We generalise some of their results such that they can be reused in other proofs. Thanks to CryptHOL's integration with Isabelle's parametricity infrastructure, many simple hops are easily justified using the theory of representation independence.

extra-history = Change history: [2018-09-28]: added the CryptHOL tutorial for game-based cryptography (revision 489a395764ae) [Multi_Party_Computation] title = Multi-Party Computation author = David Aspinall , David Butler topic = Computer science/Security date = 2019-05-09 notify = dbutler@turing.ac.uk abstract = We use CryptHOL to consider Multi-Party Computation (MPC) protocols. MPC was first considered by Yao in 1983 and recent advances in efficiency and an increased demand mean it is now deployed in the real world. Security is considered using the real/ideal world paradigm. We first define security in the semi-honest security setting where parties are assumed not to deviate from the protocol transcript. In this setting we prove multiple Oblivious Transfer (OT) protocols secure and then show security for the gates of the GMW protocol. We then define malicious security, this is a stronger notion of security where parties are assumed to be fully corrupted by an adversary. In this setting we again consider OT, as it is a fundamental building block of almost all MPC protocols. [Sigma_Commit_Crypto] title = Sigma Protocols and Commitment Schemes author = David Butler , Andreas Lochbihler topic = Computer science/Security/Cryptography date = 2019-10-07 notify = dbutler@turing.ac.uk abstract = We use CryptHOL to formalise commitment schemes and Sigma-protocols. Both are widely used fundamental two party cryptographic primitives. Security for commitment schemes is considered using game-based definitions whereas the security of Sigma-protocols is considered using both the game-based and simulation-based security paradigms. In this work, we first define security for both primitives and then prove secure multiple case studies: the Schnorr, Chaum-Pedersen and Okamoto Sigma-protocols as well as a construction that allows for compound (AND and OR statements) Sigma-protocols and the Pedersen and Rivest commitment schemes. We also prove that commitment schemes can be constructed from Sigma-protocols. We formalise this proof at an abstract level, only assuming the existence of a Sigma-protocol; consequently, the instantiations of this result for the concrete Sigma-protocols we consider come for free. [CryptHOL] title = CryptHOL author = Andreas Lochbihler topic = Computer science/Security/Cryptography, Computer science/Functional programming, Mathematics/Probability theory date = 2017-05-05 notify = mail@andreas-lochbihler.de abstract =

CryptHOL provides a framework for formalising cryptographic arguments in Isabelle/HOL. It shallowly embeds a probabilistic functional programming language in higher order logic. The language features monadic sequencing, recursion, random sampling, failures and failure handling, and black-box access to oracles. Oracles are probabilistic functions which maintain hidden state between different invocations. All operators are defined in the new semantic domain of generative probabilistic values, a codatatype. We derive proof rules for the operators and establish a connection with the theory of relational parametricity. Thus, the resuting proofs are trustworthy and comprehensible, and the framework is extensible and widely applicable.

The framework is used in the accompanying AFP entry "Game-based Cryptography in HOL". There, we show-case our framework by formalizing different game-based proofs from the literature. This formalisation continues the work described in the author's ESOP 2016 paper.

[Constructive_Cryptography] title = Constructive Cryptography in HOL author = Andreas Lochbihler , S. Reza Sefidgar<> topic = Computer science/Security/Cryptography, Mathematics/Probability theory date = 2018-12-17 notify = mail@andreas-lochbihler.de, reza.sefidgar@inf.ethz.ch abstract = Inspired by Abstract Cryptography, we extend CryptHOL, a framework for formalizing game-based proofs, with an abstract model of Random Systems and provide proof rules about their composition and equality. This foundation facilitates the formalization of Constructive Cryptography proofs, where the security of a cryptographic scheme is realized as a special form of construction in which a complex random system is built from simpler ones. This is a first step towards a fully-featured compositional framework, similar to Universal Composability framework, that supports formalization of simulation-based proofs. [Probabilistic_While] title = Probabilistic while loop author = Andreas Lochbihler topic = Computer science/Functional programming, Mathematics/Probability theory, Computer science/Algorithms date = 2017-05-05 notify = mail@andreas-lochbihler.de abstract = This AFP entry defines a probabilistic while operator based on sub-probability mass functions and formalises zero-one laws and variant rules for probabilistic loop termination. As applications, we implement probabilistic algorithms for the Bernoulli, geometric and arbitrary uniform distributions that only use fair coin flips, and prove them correct and terminating with probability 1. extra-history = Change history: [2018-02-02]: Added a proof that probabilistic conditioning can be implemented by repeated sampling. (revision 305867c4e911)
[Monad_Normalisation] title = Monad normalisation author = Joshua Schneider <>, Manuel Eberl , Andreas Lochbihler topic = Tools, Computer science/Functional programming, Logic/Rewriting date = 2017-05-05 notify = mail@andreas-lochbihler.de abstract = The usual monad laws can directly be used as rewrite rules for Isabelle’s simplifier to normalise monadic HOL terms and decide equivalences. In a commutative monad, however, the commutativity law is a higher-order permutative rewrite rule that makes the simplifier loop. This AFP entry implements a simproc that normalises monadic expressions in commutative monads using ordered rewriting. The simproc can also permute computations across control operators like if and case. [Monomorphic_Monad] title = Effect polymorphism in higher-order logic author = Andreas Lochbihler topic = Computer science/Functional programming date = 2017-05-05 notify = mail@andreas-lochbihler.de abstract = The notion of a monad cannot be expressed within higher-order logic (HOL) due to type system restrictions. We show that if a monad is used with values of only one type, this notion can be formalised in HOL. Based on this idea, we develop a library of effect specifications and implementations of monads and monad transformers. Hence, we can abstract over the concrete monad in HOL definitions and thus use the same definition for different (combinations of) effects. We illustrate the usefulness of effect polymorphism with a monadic interpreter for a simple language. extra-history = Change history: [2018-02-15]: added further specifications and implementations of non-determinism; more examples (revision bc5399eea78e)
[Constructor_Funs] title = Constructor Functions author = Lars Hupel topic = Tools date = 2017-04-19 notify = hupel@in.tum.de abstract = Isabelle's code generator performs various adaptations for target languages. Among others, constructor applications have to be fully saturated. That means that for constructor calls occuring as arguments to higher-order functions, synthetic lambdas have to be inserted. This entry provides tooling to avoid this construction altogether by introducing constructor functions. [Lazy_Case] title = Lazifying case constants author = Lars Hupel topic = Tools date = 2017-04-18 notify = hupel@in.tum.de abstract = Isabelle's code generator performs various adaptations for target languages. Among others, case statements are printed as match expressions. Internally, this is a sophisticated procedure, because in HOL, case statements are represented as nested calls to the case combinators as generated by the datatype package. Furthermore, the procedure relies on laziness of match expressions in the target language, i.e., that branches guarded by patterns that fail to match are not evaluated. Similarly, if-then-else is printed to the corresponding construct in the target language. This entry provides tooling to replace these special cases in the code generator by ignoring these target language features, instead printing case expressions and if-then-else as functions. [Dict_Construction] title = Dictionary Construction author = Lars Hupel topic = Tools date = 2017-05-24 notify = hupel@in.tum.de abstract = Isabelle's code generator natively supports type classes. For targets that do not have language support for classes and instances, it performs the well-known dictionary translation, as described by Haftmann and Nipkow. This translation happens outside the logic, i.e., there is no guarantee that it is correct, besides the pen-and-paper proof. This work implements a certified dictionary translation that produces new class-free constants and derives equality theorems. [Higher_Order_Terms] title = An Algebra for Higher-Order Terms author = Lars Hupel contributors = Yu Zhang <> topic = Computer science/Programming languages/Lambda calculi date = 2019-01-15 notify = lars@hupel.info abstract = In this formalization, I introduce a higher-order term algebra, generalizing the notions of free variables, matching, and substitution. The need arose from the work on a verified compiler from Isabelle to CakeML. Terms can be thought of as consisting of a generic (free variables, constants, application) and a specific part. As example applications, this entry provides instantiations for de-Bruijn terms, terms with named variables, and Blanchette’s λ-free higher-order terms. Furthermore, I implement translation functions between de-Bruijn terms and named terms and prove their correctness. [Subresultants] title = Subresultants author = Sebastiaan Joosten , René Thiemann , Akihisa Yamada topic = Mathematics/Algebra date = 2017-04-06 notify = rene.thiemann@uibk.ac.at abstract = We formalize the theory of subresultants and the subresultant polynomial remainder sequence as described by Brown and Traub. As a result, we obtain efficient certified algorithms for computing the resultant and the greatest common divisor of polynomials. [Comparison_Sort_Lower_Bound] title = Lower bound on comparison-based sorting algorithms author = Manuel Eberl topic = Computer science/Algorithms date = 2017-03-15 notify = eberlm@in.tum.de abstract =

This article contains a formal proof of the well-known fact that number of comparisons that a comparison-based sorting algorithm needs to perform to sort a list of length n is at least log2 (n!) in the worst case, i. e. Ω(n log n).

For this purpose, a shallow embedding for comparison-based sorting algorithms is defined: a sorting algorithm is a recursive datatype containing either a HOL function or a query of a comparison oracle with a continuation containing the remaining computation. This makes it possible to force the algorithm to use only comparisons and to track the number of comparisons made.

[Quick_Sort_Cost] title = The number of comparisons in QuickSort author = Manuel Eberl topic = Computer science/Algorithms date = 2017-03-15 notify = eberlm@in.tum.de abstract =

We give a formal proof of the well-known results about the number of comparisons performed by two variants of QuickSort: first, the expected number of comparisons of randomised QuickSort (i. e. QuickSort with random pivot choice) is 2 (n+1) Hn - 4 n, which is asymptotically equivalent to 2 n ln n; second, the number of comparisons performed by the classic non-randomised QuickSort has the same distribution in the average case as the randomised one.

[Random_BSTs] title = Expected Shape of Random Binary Search Trees author = Manuel Eberl topic = Computer science/Data structures date = 2017-04-04 notify = eberlm@in.tum.de abstract =

This entry contains proofs for the textbook results about the distributions of the height and internal path length of random binary search trees (BSTs), i. e. BSTs that are formed by taking an empty BST and inserting elements from a fixed set in random order.

In particular, we prove a logarithmic upper bound on the expected height and the Θ(n log n) closed-form solution for the expected internal path length in terms of the harmonic numbers. We also show how the internal path length relates to the average-case cost of a lookup in a BST.

[Randomised_BSTs] title = Randomised Binary Search Trees author = Manuel Eberl topic = Computer science/Data structures date = 2018-10-19 notify = eberlm@in.tum.de abstract =

This work is a formalisation of the Randomised Binary Search Trees introduced by Martínez and Roura, including definitions and correctness proofs.

Like randomised treaps, they are a probabilistic data structure that behaves exactly as if elements were inserted into a non-balancing BST in random order. However, unlike treaps, they only use discrete probability distributions, but their use of randomness is more complicated.

[E_Transcendental] title = The Transcendence of e author = Manuel Eberl topic = Mathematics/Analysis, Mathematics/Number theory date = 2017-01-12 notify = eberlm@in.tum.de abstract =

This work contains a proof that Euler's number e is transcendental. The proof follows the standard approach of assuming that e is algebraic and then using a specific integer polynomial to derive two inconsistent bounds, leading to a contradiction.

This kind of approach can be found in many different sources; this formalisation mostly follows a PlanetMath article by Roger Lipsett.

[Pi_Transcendental] title = The Transcendence of π author = Manuel Eberl topic = Mathematics/Number theory date = 2018-09-28 notify = eberlm@in.tum.de abstract =

This entry shows the transcendence of π based on the classic proof using the fundamental theorem of symmetric polynomials first given by von Lindemann in 1882, but the formalisation mostly follows the version by Niven. The proof reuses much of the machinery developed in the AFP entry on the transcendence of e.

[DFS_Framework] title = A Framework for Verifying Depth-First Search Algorithms author = Peter Lammich , René Neumann notify = lammich@in.tum.de date = 2016-07-05 topic = Computer science/Algorithms/Graph abstract =

This entry presents a framework for the modular verification of DFS-based algorithms, which is described in our [CPP-2015] paper. It provides a generic DFS algorithm framework, that can be parameterized with user-defined actions on certain events (e.g. discovery of new node). It comes with an extensible library of invariants, which can be used to derive invariants of a specific parameterization. Using refinement techniques, efficient implementations of the algorithms can easily be derived. Here, the framework comes with templates for a recursive and a tail-recursive implementation, and also with several templates for implementing the data structures required by the DFS algorithm. Finally, this entry contains a set of re-usable DFS-based algorithms, which illustrate the application of the framework.

[CPP-2015] Peter Lammich, René Neumann: A Framework for Verifying Depth-First Search Algorithms. CPP 2015: 137-146

[Flow_Networks] title = Flow Networks and the Min-Cut-Max-Flow Theorem author = Peter Lammich , S. Reza Sefidgar <> topic = Mathematics/Graph theory date = 2017-06-01 notify = lammich@in.tum.de abstract = We present a formalization of flow networks and the Min-Cut-Max-Flow theorem. Our formal proof closely follows a standard textbook proof, and is accessible even without being an expert in Isabelle/HOL, the interactive theorem prover used for the formalization. [Prpu_Maxflow] title = Formalizing Push-Relabel Algorithms author = Peter Lammich , S. Reza Sefidgar <> topic = Computer science/Algorithms/Graph, Mathematics/Graph theory date = 2017-06-01 notify = lammich@in.tum.de abstract = We present a formalization of push-relabel algorithms for computing the maximum flow in a network. We start with Goldberg's et al.~generic push-relabel algorithm, for which we show correctness and the time complexity bound of O(V^2E). We then derive the relabel-to-front and FIFO implementation. Using stepwise refinement techniques, we derive an efficient verified implementation. Our formal proof of the abstract algorithms closely follows a standard textbook proof. It is accessible even without being an expert in Isabelle/HOL, the interactive theorem prover used for the formalization. [Buildings] title = Chamber Complexes, Coxeter Systems, and Buildings author = Jeremy Sylvestre notify = jeremy.sylvestre@ualberta.ca date = 2016-07-01 topic = Mathematics/Algebra, Mathematics/Geometry abstract = We provide a basic formal framework for the theory of chamber complexes and Coxeter systems, and for buildings as thick chamber complexes endowed with a system of apartments. Along the way, we develop some of the general theory of abstract simplicial complexes and of groups (relying on the group_add class for the basics), including free groups and group presentations, and their universal properties. The main results verified are that the deletion condition is both necessary and sufficient for a group with a set of generators of order two to be a Coxeter system, and that the apartments in a (thick) building are all uniformly Coxeter. [Algebraic_VCs] title = Program Construction and Verification Components Based on Kleene Algebra author = Victor B. F. Gomes , Georg Struth notify = victor.gomes@cl.cam.ac.uk, g.struth@sheffield.ac.uk date = 2016-06-18 topic = Mathematics/Algebra abstract = Variants of Kleene algebra support program construction and verification by algebraic reasoning. This entry provides a verification component for Hoare logic based on Kleene algebra with tests, verification components for weakest preconditions and strongest postconditions based on Kleene algebra with domain and a component for step-wise refinement based on refinement Kleene algebra with tests. In addition to these components for the partial correctness of while programs, a verification component for total correctness based on divergence Kleene algebras and one for (partial correctness) of recursive programs based on domain quantales are provided. Finally we have integrated memory models for programs with pointers and a program trace semantics into the weakest precondition component. [C2KA_DistributedSystems] title = Communicating Concurrent Kleene Algebra for Distributed Systems Specification author = Maxime Buyse , Jason Jaskolka topic = Computer science/Automata and formal languages, Mathematics/Algebra date = 2019-08-06 notify = maxime.buyse@polytechnique.edu, jason.jaskolka@carleton.ca abstract = Communicating Concurrent Kleene Algebra (C²KA) is a mathematical framework for capturing the communicating and concurrent behaviour of agents in distributed systems. It extends Hoare et al.'s Concurrent Kleene Algebra (CKA) with communication actions through the notions of stimuli and shared environments. C²KA has applications in studying system-level properties of distributed systems such as safety, security, and reliability. In this work, we formalize results about C²KA and its application for distributed systems specification. We first formalize the stimulus structure and behaviour structure (CKA). Next, we combine them to formalize C²KA and its properties. Then, we formalize notions and properties related to the topology of distributed systems and the potential for communication via stimuli and via shared environments of agents, all within the algebraic setting of C²KA. [Card_Equiv_Relations] title = Cardinality of Equivalence Relations author = Lukas Bulwahn notify = lukas.bulwahn@gmail.com date = 2016-05-24 topic = Mathematics/Combinatorics abstract = This entry provides formulae for counting the number of equivalence relations and partial equivalence relations over a finite carrier set with given cardinality. To count the number of equivalence relations, we provide bijections between equivalence relations and set partitions, and then transfer the main results of the two AFP entries, Cardinality of Set Partitions and Spivey's Generalized Recurrence for Bell Numbers, to theorems on equivalence relations. To count the number of partial equivalence relations, we observe that counting partial equivalence relations over a set A is equivalent to counting all equivalence relations over all subsets of the set A. From this observation and the results on equivalence relations, we show that the cardinality of partial equivalence relations over a finite set of cardinality n is equal to the n+1-th Bell number. [Twelvefold_Way] title = The Twelvefold Way author = Lukas Bulwahn topic = Mathematics/Combinatorics date = 2016-12-29 notify = lukas.bulwahn@gmail.com abstract = This entry provides all cardinality theorems of the Twelvefold Way. The Twelvefold Way systematically classifies twelve related combinatorial problems concerning two finite sets, which include counting permutations, combinations, multisets, set partitions and number partitions. This development builds upon the existing formal developments with cardinality theorems for those structures. It provides twelve bijections from the various structures to different equivalence classes on finite functions, and hence, proves cardinality formulae for these equivalence classes on finite functions. [Chord_Segments] title = Intersecting Chords Theorem author = Lukas Bulwahn notify = lukas.bulwahn@gmail.com date = 2016-10-11 topic = Mathematics/Geometry abstract = This entry provides a geometric proof of the intersecting chords theorem. The theorem states that when two chords intersect each other inside a circle, the products of their segments are equal. After a short review of existing proofs in the literature, I decided to use a proof approach that employs reasoning about lengths of line segments, the orthogonality of two lines and the Pythagoras Law. Hence, one can understand the formalized proof easily with the knowledge of a few general geometric facts that are commonly taught in high-school. This theorem is the 55th theorem of the Top 100 Theorems list. [Category3] title = Category Theory with Adjunctions and Limits author = Eugene W. Stark notify = stark@cs.stonybrook.edu date = 2016-06-26 topic = Mathematics/Category theory abstract = This article attempts to develop a usable framework for doing category theory in Isabelle/HOL. Our point of view, which to some extent differs from that of the previous AFP articles on the subject, is to try to explore how category theory can be done efficaciously within HOL, rather than trying to match exactly the way things are done using a traditional approach. To this end, we define the notion of category in an "object-free" style, in which a category is represented by a single partial composition operation on arrows. This way of defining categories provides some advantages in the context of HOL, including the ability to avoid the use of records and the possibility of defining functors and natural transformations simply as certain functions on arrows, rather than as composite objects. We define various constructions associated with the basic notions, including: dual category, product category, functor category, discrete category, free category, functor composition, and horizontal and vertical composite of natural transformations. A "set category" locale is defined that axiomatizes the notion "category of all sets at a type and all functions between them," and a fairly extensive set of properties of set categories is derived from the locale assumptions. The notion of a set category is used to prove the Yoneda Lemma in a general setting of a category equipped with a "hom embedding," which maps arrows of the category to the "universe" of the set category. We also give a treatment of adjunctions, defining adjunctions via left and right adjoint functors, natural bijections between hom-sets, and unit and counit natural transformations, and showing the equivalence of these definitions. We also develop the theory of limits, including representations of functors, diagrams and cones, and diagonal functors. We show that right adjoint functors preserve limits, and that limits can be constructed via products and equalizers. We characterize the conditions under which limits exist in a set category. We also examine the case of limits in a functor category, ultimately culminating in a proof that the Yoneda embedding preserves limits. extra-history = Change history: [2018-05-29]: Revised axioms for the category locale. Introduced notation for composition and "in hom". (revision 8318366d4575)
[2020-02-15]: Move ConcreteCategory.thy from Bicategory to Category3 and use it systematically. Make other minor improvements throughout. (revision a51840d36867)
[MonoidalCategory] title = Monoidal Categories author = Eugene W. Stark topic = Mathematics/Category theory date = 2017-05-04 notify = stark@cs.stonybrook.edu abstract = Building on the formalization of basic category theory set out in the author's previous AFP article, the present article formalizes some basic aspects of the theory of monoidal categories. Among the notions defined here are monoidal category, monoidal functor, and equivalence of monoidal categories. The main theorems formalized are MacLane's coherence theorem and the constructions of the free monoidal category and free strict monoidal category generated by a given category. The coherence theorem is proved syntactically, using a structurally recursive approach to reduction of terms that might have some novel aspects. We also give proofs of some results given by Etingof et al, which may prove useful in a formal setting. In particular, we show that the left and right unitors need not be taken as given data in the definition of monoidal category, nor does the definition of monoidal functor need to take as given a specific isomorphism expressing the preservation of the unit object. Our definitions of monoidal category and monoidal functor are stated so as to take advantage of the economy afforded by these facts. extra-history = Change history: [2017-05-18]: Integrated material from MonoidalCategory/Category3Adapter into Category3/ and deleted adapter. (revision 015543cdd069)
[2018-05-29]: Modifications required due to 'Category3' changes. Introduced notation for "in hom". (revision 8318366d4575)
[2020-02-15]: Cosmetic improvements. (revision a51840d36867)
[Card_Multisets] title = Cardinality of Multisets author = Lukas Bulwahn notify = lukas.bulwahn@gmail.com date = 2016-06-26 topic = Mathematics/Combinatorics abstract =

This entry provides three lemmas to count the number of multisets of a given size and finite carrier set. The first lemma provides a cardinality formula assuming that the multiset's elements are chosen from the given carrier set. The latter two lemmas provide formulas assuming that the multiset's elements also cover the given carrier set, i.e., each element of the carrier set occurs in the multiset at least once.

The proof of the first lemma uses the argument of the recurrence relation for counting multisets. The proof of the second lemma is straightforward, and the proof of the third lemma is easily obtained using the first cardinality lemma. A challenge for the formalization is the derivation of the required induction rule, which is a special combination of the induction rules for finite sets and natural numbers. The induction rule is derived by defining a suitable inductive predicate and transforming the predicate's induction rule.

[Posix-Lexing] title = POSIX Lexing with Derivatives of Regular Expressions author = Fahad Ausaf , Roy Dyckhoff , Christian Urban notify = christian.urban@kcl.ac.uk date = 2016-05-24 topic = Computer science/Automata and formal languages abstract = Brzozowski introduced the notion of derivatives for regular expressions. They can be used for a very simple regular expression matching algorithm. Sulzmann and Lu cleverly extended this algorithm in order to deal with POSIX matching, which is the underlying disambiguation strategy for regular expressions needed in lexers. In this entry we give our inductive definition of what a POSIX value is and show (i) that such a value is unique (for given regular expression and string being matched) and (ii) that Sulzmann and Lu's algorithm always generates such a value (provided that the regular expression matches the string). We also prove the correctness of an optimised version of the POSIX matching algorithm. [LocalLexing] title = Local Lexing author = Steven Obua topic = Computer science/Automata and formal languages date = 2017-04-28 notify = steven@recursivemind.com abstract = This formalisation accompanies the paper Local Lexing which introduces a novel parsing concept of the same name. The paper also gives a high-level algorithm for local lexing as an extension of Earley's algorithm. This formalisation proves the algorithm to be correct with respect to its local lexing semantics. As a special case, this formalisation thus also contains a proof of the correctness of Earley's algorithm. The paper contains a short outline of how this formalisation is organised. [MFMC_Countable] title = A Formal Proof of the Max-Flow Min-Cut Theorem for Countable Networks author = Andreas Lochbihler date = 2016-05-09 topic = Mathematics/Graph theory abstract = This article formalises a proof of the maximum-flow minimal-cut theorem for networks with countably many edges. A network is a directed graph with non-negative real-valued edge labels and two dedicated vertices, the source and the sink. A flow in a network assigns non-negative real numbers to the edges such that for all vertices except for the source and the sink, the sum of values on incoming edges equals the sum of values on outgoing edges. A cut is a subset of the vertices which contains the source, but not the sink. Our theorem states that in every network, there is a flow and a cut such that the flow saturates all the edges going out of the cut and is zero on all the incoming edges. The proof is based on the paper The Max-Flow Min-Cut theorem for countable networks by Aharoni et al. Additionally, we prove a characterisation of the lifting operation for relations on discrete probability distributions, which leads to a concise proof of its distributivity over relation composition. notify = mail@andreas-lochbihler.de extra-history = Change history: [2017-09-06]: derive characterisation for the lifting operations on discrete distributions from finite version of the max-flow min-cut theorem (revision a7a198f5bab0)
[Liouville_Numbers] title = Liouville numbers author = Manuel Eberl date = 2015-12-28 topic = Mathematics/Analysis, Mathematics/Number theory abstract =

Liouville numbers are a class of transcendental numbers that can be approximated particularly well with rational numbers. Historically, they were the first numbers whose transcendence was proven.

In this entry, we define the concept of Liouville numbers as well as the standard construction to obtain Liouville numbers (including Liouville's constant) and we prove their most important properties: irrationality and transcendence.

The proof is very elementary and requires only standard arithmetic, the Mean Value Theorem for polynomials, and the boundedness of polynomials on compact intervals.

notify = eberlm@in.tum.de [Triangle] title = Basic Geometric Properties of Triangles author = Manuel Eberl date = 2015-12-28 topic = Mathematics/Geometry abstract =

This entry contains a definition of angles between vectors and between three points. Building on this, we prove basic geometric properties of triangles, such as the Isosceles Triangle Theorem, the Law of Sines and the Law of Cosines, that the sum of the angles of a triangle is π, and the congruence theorems for triangles.

The definitions and proofs were developed following those by John Harrison in HOL Light. However, due to Isabelle's type class system, all definitions and theorems in the Isabelle formalisation hold for all real inner product spaces.

notify = eberlm@in.tum.de [Prime_Harmonic_Series] title = The Divergence of the Prime Harmonic Series author = Manuel Eberl date = 2015-12-28 topic = Mathematics/Number theory abstract =

In this work, we prove the lower bound ln(H_n) - ln(5/3) for the partial sum of the Prime Harmonic series and, based on this, the divergence of the Prime Harmonic Series ∑[p prime] · 1/p.

The proof relies on the unique squarefree decomposition of natural numbers. This is similar to Euler's original proof (which was highly informal and morally questionable). Its advantage over proofs by contradiction, like the famous one by Paul Erdős, is that it provides a relatively good lower bound for the partial sums.

notify = eberlm@in.tum.de [Descartes_Sign_Rule] title = Descartes' Rule of Signs author = Manuel Eberl date = 2015-12-28 topic = Mathematics/Analysis abstract =

Descartes' Rule of Signs relates the number of positive real roots of a polynomial with the number of sign changes in its coefficient sequence.

Our proof follows the simple inductive proof given by Rob Arthan, which was also used by John Harrison in his HOL Light formalisation. We proved most of the lemmas for arbitrary linearly-ordered integrity domains (e.g. integers, rationals, reals); the main result, however, requires the intermediate value theorem and was therefore only proven for real polynomials.

notify = eberlm@in.tum.de [Euler_MacLaurin] title = The Euler–MacLaurin Formula author = Manuel Eberl topic = Mathematics/Analysis date = 2017-03-10 notify = eberlm@in.tum.de abstract =

The Euler-MacLaurin formula relates the value of a discrete sum to that of the corresponding integral in terms of the derivatives at the borders of the summation and a remainder term. Since the remainder term is often very small as the summation bounds grow, this can be used to compute asymptotic expansions for sums.

This entry contains a proof of this formula for functions from the reals to an arbitrary Banach space. Two variants of the formula are given: the standard textbook version and a variant outlined in Concrete Mathematics that is more useful for deriving asymptotic estimates.

As example applications, we use that formula to derive the full asymptotic expansion of the harmonic numbers and the sum of inverse squares.

[Card_Partitions] title = Cardinality of Set Partitions author = Lukas Bulwahn date = 2015-12-12 topic = Mathematics/Combinatorics abstract = The theory's main theorem states that the cardinality of set partitions of size k on a carrier set of size n is expressed by Stirling numbers of the second kind. In Isabelle, Stirling numbers of the second kind are defined in the AFP entry `Discrete Summation` through their well-known recurrence relation. The main theorem relates them to the alternative definition as cardinality of set partitions. The proof follows the simple and short explanation in Richard P. Stanley's `Enumerative Combinatorics: Volume 1` and Wikipedia, and unravels the full details and implicit reasoning steps of these explanations. notify = lukas.bulwahn@gmail.com [Card_Number_Partitions] title = Cardinality of Number Partitions author = Lukas Bulwahn date = 2016-01-14 topic = Mathematics/Combinatorics abstract = This entry provides a basic library for number partitions, defines the two-argument partition function through its recurrence relation and relates this partition function to the cardinality of number partitions. The main proof shows that the recursively-defined partition function with arguments n and k equals the cardinality of number partitions of n with exactly k parts. The combinatorial proof follows the proof sketch of Theorem 2.4.1 in Mazur's textbook `Combinatorics: A Guided Tour`. This entry can serve as starting point for various more intrinsic properties about number partitions, the partition function and related recurrence relations. notify = lukas.bulwahn@gmail.com [Multirelations] title = Binary Multirelations author = Hitoshi Furusawa , Georg Struth date = 2015-06-11 topic = Mathematics/Algebra abstract = Binary multirelations associate elements of a set with its subsets; hence they are binary relations from a set to its power set. Applications include alternating automata, models and logics for games, program semantics with dual demonic and angelic nondeterministic choices and concurrent dynamic logics. This proof document supports an arXiv article that formalises the basic algebra of multirelations and proposes axiom systems for them, ranging from weak bi-monoids to weak bi-quantales. notify = [Noninterference_Generic_Unwinding] title = The Generic Unwinding Theorem for CSP Noninterference Security author = Pasquale Noce date = 2015-06-11 topic = Computer science/Security, Computer science/Concurrency/Process calculi abstract =

The classical definition of noninterference security for a deterministic state machine with outputs requires to consider the outputs produced by machine actions after any trace, i.e. any indefinitely long sequence of actions, of the machine. In order to render the verification of the security of such a machine more straightforward, there is a need of some sufficient condition for security such that just individual actions, rather than unbounded sequences of actions, have to be considered.

By extending previous results applying to transitive noninterference policies, Rushby has proven an unwinding theorem that provides a sufficient condition of this kind in the general case of a possibly intransitive policy. This condition has to be satisfied by a generic function mapping security domains into equivalence relations over machine states.

An analogous problem arises for CSP noninterference security, whose definition requires to consider any possible future, i.e. any indefinitely long sequence of subsequent events and any indefinitely large set of refused events associated to that sequence, for each process trace.

This paper provides a sufficient condition for CSP noninterference security, which indeed requires to just consider individual accepted and refused events and applies to the general case of a possibly intransitive policy. This condition follows Rushby's one for classical noninterference security, and has to be satisfied by a generic function mapping security domains into equivalence relations over process traces; hence its name, Generic Unwinding Theorem. Variants of this theorem applying to deterministic processes and trace set processes are also proven. Finally, the sufficient condition for security expressed by the theorem is shown not to be a necessary condition as well, viz. there exists a secure process such that no domain-relation map satisfying the condition exists.

notify = [Noninterference_Ipurge_Unwinding] title = The Ipurge Unwinding Theorem for CSP Noninterference Security author = Pasquale Noce date = 2015-06-11 topic = Computer science/Security abstract =

The definition of noninterference security for Communicating Sequential Processes requires to consider any possible future, i.e. any indefinitely long sequence of subsequent events and any indefinitely large set of refused events associated to that sequence, for each process trace. In order to render the verification of the security of a process more straightforward, there is a need of some sufficient condition for security such that just individual accepted and refused events, rather than unbounded sequences and sets of events, have to be considered.

Of course, if such a sufficient condition were necessary as well, it would be even more valuable, since it would permit to prove not only that a process is secure by verifying that the condition holds, but also that a process is not secure by verifying that the condition fails to hold.

This paper provides a necessary and sufficient condition for CSP noninterference security, which indeed requires to just consider individual accepted and refused events and applies to the general case of a possibly intransitive policy. This condition follows Rushby's output consistency for deterministic state machines with outputs, and has to be satisfied by a specific function mapping security domains into equivalence relations over process traces. The definition of this function makes use of an intransitive purge function following Rushby's one; hence the name given to the condition, Ipurge Unwinding Theorem.

Furthermore, in accordance with Hoare's formal definition of deterministic processes, it is shown that a process is deterministic just in case it is a trace set process, i.e. it may be identified by means of a trace set alone, matching the set of its traces, in place of a failures-divergences pair. Then, variants of the Ipurge Unwinding Theorem are proven for deterministic processes and trace set processes.

notify = [List_Interleaving] title = Reasoning about Lists via List Interleaving author = Pasquale Noce date = 2015-06-11 topic = Computer science/Data structures abstract =

Among the various mathematical tools introduced in his outstanding work on Communicating Sequential Processes, Hoare has defined "interleaves" as the predicate satisfied by any three lists such that the first list may be split into sublists alternately extracted from the other two ones, whatever is the criterion for extracting an item from either one list or the other in each step.

This paper enriches Hoare's definition by identifying such criterion with the truth value of a predicate taking as inputs the head and the tail of the first list. This enhanced "interleaves" predicate turns out to permit the proof of equalities between lists without the need of an induction. Some rules that allow to infer "interleaves" statements without induction, particularly applying to the addition or removal of a prefix to the input lists, are also proven. Finally, a stronger version of the predicate, named "Interleaves", is shown to fulfil further rules applying to the addition or removal of a suffix to the input lists.

notify = [Residuated_Lattices] title = Residuated Lattices author = Victor B. F. Gomes , Georg Struth date = 2015-04-15 topic = Mathematics/Algebra abstract = The theory of residuated lattices, first proposed by Ward and Dilworth, is formalised in Isabelle/HOL. This includes concepts of residuated functions; their adjoints and conjugates. It also contains necessary and sufficient conditions for the existence of these operations in an arbitrary lattice. The mathematical components for residuated lattices are linked to the AFP entry for relation algebra. In particular, we prove Jonsson and Tsinakis conditions for a residuated boolean algebra to form a relation algebra. notify = g.struth@sheffield.ac.uk [ConcurrentGC] title = Relaxing Safely: Verified On-the-Fly Garbage Collection for x86-TSO author = Peter Gammie , Tony Hosking , Kai Engelhardt <> date = 2015-04-13 topic = Computer science/Algorithms/Concurrent abstract =

We use ConcurrentIMP to model Schism, a state-of-the-art real-time garbage collection scheme for weak memory, and show that it is safe on x86-TSO.

This development accompanies the PLDI 2015 paper of the same name.

notify = peteg42@gmail.com [List_Update] title = Analysis of List Update Algorithms author = Maximilian P.L. Haslbeck , Tobias Nipkow date = 2016-02-17 topic = Computer science/Algorithms/Online abstract =

These theories formalize the quantitative analysis of a number of classical algorithms for the list update problem: 2-competitiveness of move-to-front, the lower bound of 2 for the competitiveness of deterministic list update algorithms and 1.6-competitiveness of the randomized COMB algorithm, the best randomized list update algorithm known to date. The material is based on the first two chapters of Online Computation and Competitive Analysis by Borodin and El-Yaniv.

For an informal description see the FSTTCS 2016 publication Verified Analysis of List Update Algorithms by Haslbeck and Nipkow.

notify = nipkow@in.tum.de [ConcurrentIMP] title = Concurrent IMP author = Peter Gammie date = 2015-04-13 topic = Computer science/Programming languages/Logics abstract = ConcurrentIMP extends the small imperative language IMP with control non-determinism and constructs for synchronous message passing. notify = peteg42@gmail.com [TortoiseHare] title = The Tortoise and Hare Algorithm author = Peter Gammie date = 2015-11-18 topic = Computer science/Algorithms abstract = We formalize the Tortoise and Hare cycle-finding algorithm ascribed to Floyd by Knuth, and an improved version due to Brent. notify = peteg42@gmail.com [UPF] title = The Unified Policy Framework (UPF) author = Achim D. Brucker , Lukas Brügger , Burkhart Wolff date = 2014-11-28 topic = Computer science/Security abstract = We present the Unified Policy Framework (UPF), a generic framework for modelling security (access-control) policies. UPF emphasizes the view that a policy is a policy decision function that grants or denies access to resources, permissions, etc. In other words, instead of modelling the relations of permitted or prohibited requests directly, we model the concrete function that implements the policy decision point in a system. In more detail, UPF is based on the following four principles: 1) Functional representation of policies, 2) No conflicts are possible, 3) Three-valued decision type (allow, deny, undefined), 4) Output type not containing the decision only. notify = adbrucker@0x5f.org, wolff@lri.fr, lukas.a.bruegger@gmail.com [UPF_Firewall] title = Formal Network Models and Their Application to Firewall Policies author = Achim D. Brucker , Lukas Brügger<>, Burkhart Wolff topic = Computer science/Security, Computer science/Networks date = 2017-01-08 notify = adbrucker@0x5f.org abstract = We present a formal model of network protocols and their application to modeling firewall policies. The formalization is based on the Unified Policy Framework (UPF). The formalization was originally developed with for generating test cases for testing the security configuration actual firewall and router (middle-boxes) using HOL-TestGen. Our work focuses on modeling application level protocols on top of tcp/ip. [AODV] title = Loop freedom of the (untimed) AODV routing protocol author = Timothy Bourke , Peter Höfner date = 2014-10-23 topic = Computer science/Concurrency/Process calculi abstract =

The Ad hoc On-demand Distance Vector (AODV) routing protocol allows the nodes in a Mobile Ad hoc Network (MANET) or a Wireless Mesh Network (WMN) to know where to forward data packets. Such a protocol is ‘loop free’ if it never leads to routing decisions that forward packets in circles.

This development mechanises an existing pen-and-paper proof of loop freedom of AODV. The protocol is modelled in the Algebra of Wireless Networks (AWN), which is the subject of an earlier paper and AFP mechanization. The proof relies on a novel compositional approach for lifting invariants to networks of nodes.

We exploit the mechanization to analyse several variants of AODV and show that Isabelle/HOL can re-establish most proof obligations automatically and identify exactly the steps that are no longer valid.

notify = tim@tbrk.org [Show] title = Haskell's Show Class in Isabelle/HOL author = Christian Sternagel , René Thiemann date = 2014-07-29 topic = Computer science/Functional programming license = LGPL abstract = We implemented a type class for "to-string" functions, similar to Haskell's Show class. Moreover, we provide instantiations for Isabelle/HOL's standard types like bool, prod, sum, nats, ints, and rats. It is further possible, to automatically derive show functions for arbitrary user defined datatypes similar to Haskell's "deriving Show". extra-history = Change history: [2015-03-11]: Adapted development to new-style (BNF-based) datatypes.
[2015-04-10]: Moved development for old-style datatypes into subdirectory "Old_Datatype".
notify = christian.sternagel@uibk.ac.at, rene.thiemann@uibk.ac.at [Certification_Monads] title = Certification Monads author = Christian Sternagel , René Thiemann date = 2014-10-03 topic = Computer science/Functional programming abstract = This entry provides several monads intended for the development of stand-alone certifiers via code generation from Isabelle/HOL. More specifically, there are three flavors of error monads (the sum type, for the case where all monadic functions are total; an instance of the former, the so called check monad, yielding either success without any further information or an error message; as well as a variant of the sum type that accommodates partial functions by providing an explicit bottom element) and a parser monad built on top. All of this monads are heavily used in the IsaFoR/CeTA project which thus provides many examples of their usage. notify = c.sternagel@gmail.com, rene.thiemann@uibk.ac.at [CISC-Kernel] title = Formal Specification of a Generic Separation Kernel author = Freek Verbeek , Sergey Tverdyshev , Oto Havle , Holger Blasum , Bruno Langenstein , Werner Stephan , Yakoub Nemouchi , Abderrahmane Feliachi , Burkhart Wolff , Julien Schmaltz date = 2014-07-18 topic = Computer science/Security abstract =

Intransitive noninterference has been a widely studied topic in the last few decades. Several well-established methodologies apply interactive theorem proving to formulate a noninterference theorem over abstract academic models. In joint work with several industrial and academic partners throughout Europe, we are helping in the certification process of PikeOS, an industrial separation kernel developed at SYSGO. In this process, established theories could not be applied. We present a new generic model of separation kernels and a new theory of intransitive noninterference. The model is rich in detail, making it suitable for formal verification of realistic and industrial systems such as PikeOS. Using a refinement-based theorem proving approach, we ensure that proofs remain manageable.

This document corresponds to the deliverable D31.1 of the EURO-MILS Project http://www.euromils.eu.

notify = [pGCL] title = pGCL for Isabelle author = David Cock date = 2014-07-13 topic = Computer science/Programming languages/Language definitions abstract =

pGCL is both a programming language and a specification language that incorporates both probabilistic and nondeterministic choice, in a unified manner. Program verification is by refinement or annotation (or both), using either Hoare triples, or weakest-precondition entailment, in the style of GCL.

This package provides both a shallow embedding of the language primitives, and an annotation and refinement framework. The generated document includes a brief tutorial.

notify = [Noninterference_CSP] title = Noninterference Security in Communicating Sequential Processes author = Pasquale Noce date = 2014-05-23 topic = Computer science/Security abstract =

An extension of classical noninterference security for deterministic state machines, as introduced by Goguen and Meseguer and elegantly formalized by Rushby, to nondeterministic systems should satisfy two fundamental requirements: it should be based on a mathematically precise theory of nondeterminism, and should be equivalent to (or at least not weaker than) the classical notion in the degenerate deterministic case.

This paper proposes a definition of noninterference security applying to Hoare's Communicating Sequential Processes (CSP) in the general case of a possibly intransitive noninterference policy, and proves the equivalence of this security property to classical noninterference security for processes representing deterministic state machines.

Furthermore, McCullough's generalized noninterference security is shown to be weaker than both the proposed notion of CSP noninterference security for a generic process, and classical noninterference security for processes representing deterministic state machines. This renders CSP noninterference security preferable as an extension of classical noninterference security to nondeterministic systems.

notify = pasquale.noce.lavoro@gmail.com [Floyd_Warshall] title = The Floyd-Warshall Algorithm for Shortest Paths author = Simon Wimmer , Peter Lammich topic = Computer science/Algorithms/Graph date = 2017-05-08 notify = wimmers@in.tum.de abstract = The Floyd-Warshall algorithm [Flo62, Roy59, War62] is a classic dynamic programming algorithm to compute the length of all shortest paths between any two vertices in a graph (i.e. to solve the all-pairs shortest path problem, or APSP for short). Given a representation of the graph as a matrix of weights M, it computes another matrix M' which represents a graph with the same path lengths and contains the length of the shortest path between any two vertices i and j. This is only possible if the graph does not contain any negative cycles. However, in this case the Floyd-Warshall algorithm will detect the situation by calculating a negative diagonal entry. This entry includes a formalization of the algorithm and of these key properties. The algorithm is refined to an efficient imperative version using the Imperative Refinement Framework. [Roy_Floyd_Warshall] title = Transitive closure according to Roy-Floyd-Warshall author = Makarius Wenzel <> date = 2014-05-23 topic = Computer science/Algorithms/Graph abstract = This formulation of the Roy-Floyd-Warshall algorithm for the transitive closure bypasses matrices and arrays, but uses a more direct mathematical model with adjacency functions for immediate predecessors and successors. This can be implemented efficiently in functional programming languages and is particularly adequate for sparse relations. notify = [GPU_Kernel_PL] title = Syntax and semantics of a GPU kernel programming language author = John Wickerson date = 2014-04-03 topic = Computer science/Programming languages/Language definitions abstract = This document accompanies the article "The Design and Implementation of a Verification Technique for GPU Kernels" by Adam Betts, Nathan Chong, Alastair F. Donaldson, Jeroen Ketema, Shaz Qadeer, Paul Thomson and John Wickerson. It formalises all of the definitions provided in Sections 3 and 4 of the article. notify = [AWN] title = Mechanization of the Algebra for Wireless Networks (AWN) author = Timothy Bourke date = 2014-03-08 topic = Computer science/Concurrency/Process calculi abstract =

AWN is a process algebra developed for modelling and analysing protocols for Mobile Ad hoc Networks (MANETs) and Wireless Mesh Networks (WMNs). AWN models comprise five distinct layers: sequential processes, local parallel compositions, nodes, partial networks, and complete networks.

This development mechanises the original operational semantics of AWN and introduces a variant 'open' operational semantics that enables the compositional statement and proof of invariants across distinct network nodes. It supports labels (for weakening invariants) and (abstract) data state manipulations. A framework for compositional invariant proofs is developed, including a tactic (inv_cterms) for inductive invariant proofs of sequential processes, lifting rules for the open versions of the higher layers, and a rule for transferring lifted properties back to the standard semantics. A notion of 'control terms' reduces proof obligations to the subset of subterms that act directly (in contrast to operators for combining terms and joining processes).

notify = tim@tbrk.org [Selection_Heap_Sort] title = Verification of Selection and Heap Sort Using Locales author = Danijela Petrovic date = 2014-02-11 topic = Computer science/Algorithms abstract = Stepwise program refinement techniques can be used to simplify program verification. Programs are better understood since their main properties are clearly stated, and verification of rather complex algorithms is reduced to proving simple statements connecting successive program specifications. Additionally, it is easy to analyze similar algorithms and to compare their properties within a single formalization. Usually, formal analysis is not done in educational setting due to complexity of verification and a lack of tools and procedures to make comparison easy. Verification of an algorithm should not only give correctness proof, but also better understanding of an algorithm. If the verification is based on small step program refinement, it can become simple enough to be demonstrated within the university-level computer science curriculum. In this paper we demonstrate this and give a formal analysis of two well known algorithms (Selection Sort and Heap Sort) using proof assistant Isabelle/HOL and program refinement techniques. notify = [Real_Impl] title = Implementing field extensions of the form Q[sqrt(b)] author = René Thiemann date = 2014-02-06 license = LGPL topic = Mathematics/Analysis abstract = We apply data refinement to implement the real numbers, where we support all numbers in the field extension Q[sqrt(b)], i.e., all numbers of the form p + q * sqrt(b) for rational numbers p and q and some fixed natural number b. To this end, we also developed algorithms to precisely compute roots of a rational number, and to perform a factorization of natural numbers which eliminates duplicate prime factors.

Our results have been used to certify termination proofs which involve polynomial interpretations over the reals. extra-history = Change history: [2014-07-11]: Moved NthRoot_Impl to Sqrt-Babylonian. notify = rene.thiemann@uibk.ac.at [ShortestPath] title = An Axiomatic Characterization of the Single-Source Shortest Path Problem author = Christine Rizkallah date = 2013-05-22 topic = Mathematics/Graph theory abstract = This theory is split into two sections. In the first section, we give a formal proof that a well-known axiomatic characterization of the single-source shortest path problem is correct. Namely, we prove that in a directed graph with a non-negative cost function on the edges the single-source shortest path function is the only function that satisfies a set of four axioms. In the second section, we give a formal proof of the correctness of an axiomatic characterization of the single-source shortest path problem for directed graphs with general cost functions. The axioms here are more involved because we have to account for potential negative cycles in the graph. The axioms are summarized in three Isabelle locales. notify = [Launchbury] title = The Correctness of Launchbury's Natural Semantics for Lazy Evaluation author = Joachim Breitner date = 2013-01-31 topic = Computer science/Programming languages/Lambda calculi, Computer science/Semantics abstract = In his seminal paper "Natural Semantics for Lazy Evaluation", John Launchbury proves his semantics correct with respect to a denotational semantics, and outlines an adequacy proof. We have formalized both semantics and machine-checked the correctness proof, clarifying some details. Furthermore, we provide a new and more direct adequacy proof that does not require intermediate operational semantics. extra-history = Change history: [2014-05-24]: Added the proof of adequacy, as well as simplified and improved the existing proofs. Adjusted abstract accordingly. [2015-03-16]: Booleans and if-then-else added to syntax and semantics, making this entry suitable to be used by the entry "Call_Arity". notify = [Call_Arity] title = The Safety of Call Arity author = Joachim Breitner date = 2015-02-20 topic = Computer science/Programming languages/Transformations abstract = We formalize the Call Arity analysis, as implemented in GHC, and prove both functional correctness and, more interestingly, safety (i.e. the transformation does not increase allocation).

We use syntax and the denotational semantics from the entry "Launchbury", where we formalized Launchbury's natural semantics for lazy evaluation.

The functional correctness of Call Arity is proved with regard to that denotational semantics. The operational properties are shown with regard to a small-step semantics akin to Sestoft's mark 1 machine, which we prove to be equivalent to Launchbury's semantics.

We use Christian Urban's Nominal2 package to define our terms and make use of Brian Huffman's HOLCF package for the domain-theoretical aspects of the development. extra-history = Change history: [2015-03-16]: This entry now builds on top of the Launchbury entry, and the equivalency proof of the natural and the small-step semantics was added. notify = [CCS] title = CCS in nominal logic author = Jesper Bengtson date = 2012-05-29 topic = Computer science/Concurrency/Process calculi abstract = We formalise a large portion of CCS as described in Milner's book 'Communication and Concurrency' using the nominal datatype package in Isabelle. Our results include many of the standard theorems of bisimulation equivalence and congruence, for both weak and strong versions. One main goal of this formalisation is to keep the machine-checked proofs as close to their pen-and-paper counterpart as possible.

This entry is described in detail in Bengtson's thesis. notify = [Pi_Calculus] title = The pi-calculus in nominal logic author = Jesper Bengtson date = 2012-05-29 topic = Computer science/Concurrency/Process calculi abstract = We formalise the pi-calculus using the nominal datatype package, based on ideas from the nominal logic by Pitts et al., and demonstrate an implementation in Isabelle/HOL. The purpose is to derive powerful induction rules for the semantics in order to conduct machine checkable proofs, closely following the intuitive arguments found in manual proofs. In this way we have covered many of the standard theorems of bisimulation equivalence and congruence, both late and early, and both strong and weak in a uniform manner. We thus provide one of the most extensive formalisations of a the pi-calculus ever done inside a theorem prover.

A significant gain in our formulation is that agents are identified up to alpha-equivalence, thereby greatly reducing the arguments about bound names. This is a normal strategy for manual proofs about the pi-calculus, but that kind of hand waving has previously been difficult to incorporate smoothly in an interactive theorem prover. We show how the nominal logic formalism and its support in Isabelle accomplishes this and thus significantly reduces the tedium of conducting completely formal proofs. This improves on previous work using weak higher order abstract syntax since we do not need extra assumptions to filter out exotic terms and can keep all arguments within a familiar first-order logic.

This entry is described in detail in Bengtson's thesis. notify = [Psi_Calculi] title = Psi-calculi in Isabelle author = Jesper Bengtson date = 2012-05-29 topic = Computer science/Concurrency/Process calculi abstract = Psi-calculi are extensions of the pi-calculus, accommodating arbitrary nominal datatypes to represent not only data but also communication channels, assertions and conditions, giving it an expressive power beyond the applied pi-calculus and the concurrent constraint pi-calculus.

We have formalised psi-calculi in the interactive theorem prover Isabelle using its nominal datatype package. One distinctive feature is that the framework needs to treat binding sequences, as opposed to single binders, in an efficient way. While different methods for formalising single binder calculi have been proposed over the last decades, representations for such binding sequences are not very well explored.

The main effort in the formalisation is to keep the machine checked proofs as close to their pen-and-paper counterparts as possible. This includes treating all binding sequences as atomic elements, and creating custom induction and inversion rules that to remove the bulk of manual alpha-conversions.

This entry is described in detail in Bengtson's thesis. notify = [Encodability_Process_Calculi] title = Analysing and Comparing Encodability Criteria for Process Calculi author = Kirstin Peters , Rob van Glabbeek date = 2015-08-10 topic = Computer science/Concurrency/Process calculi abstract = Encodings or the proof of their absence are the main way to compare process calculi. To analyse the quality of encodings and to rule out trivial or meaningless encodings, they are augmented with quality criteria. There exists a bunch of different criteria and different variants of criteria in order to reason in different settings. This leads to incomparable results. Moreover it is not always clear whether the criteria used to obtain a result in a particular setting do indeed fit to this setting. We show how to formally reason about and compare encodability criteria by mapping them on requirements on a relation between source and target terms that is induced by the encoding function. In particular we analyse the common criteria full abstraction, operational correspondence, divergence reflection, success sensitiveness, and respect of barbs; e.g. we analyse the exact nature of the simulation relation (coupled simulation versus bisimulation) that is induced by different variants of operational correspondence. This way we reduce the problem of analysing or comparing encodability criteria to the better understood problem of comparing relations on processes. notify = kirstin.peters@tu-berlin.de [Circus] title = Isabelle/Circus author = Abderrahmane Feliachi , Burkhart Wolff , Marie-Claude Gaudel contributors = Makarius Wenzel date = 2012-05-27 topic = Computer science/Concurrency/Process calculi, Computer science/System description languages abstract = The Circus specification language combines elements for complex data and behavior specifications, using an integration of Z and CSP with a refinement calculus. Its semantics is based on Hoare and He's Unifying Theories of Programming (UTP). Isabelle/Circus is a formalization of the UTP and the Circus language in Isabelle/HOL. It contains proof rules and tactic support that allows for proofs of refinement for Circus processes (involving both data and behavioral aspects).

The Isabelle/Circus environment supports a syntax for the semantic definitions which is close to textbook presentations of Circus. This article contains an extended version of corresponding VSTTE Paper together with the complete formal development of its underlying commented theories. extra-history = Change history: [2014-06-05]: More polishing, shorter proofs, added Circus syntax, added Makarius Wenzel as contributor. notify = [Dijkstra_Shortest_Path] title = Dijkstra's Shortest Path Algorithm author = Benedikt Nordhoff , Peter Lammich topic = Computer science/Algorithms/Graph date = 2012-01-30 abstract = We implement and prove correct Dijkstra's algorithm for the single source shortest path problem, conceived in 1956 by E. Dijkstra. The algorithm is implemented using the data refinement framework for monadic, nondeterministic programs. An efficient implementation is derived using data structures from the Isabelle Collection Framework. notify = lammich@in.tum.de [Refine_Monadic] title = Refinement for Monadic Programs author = Peter Lammich topic = Computer science/Programming languages/Logics date = 2012-01-30 abstract = We provide a framework for program and data refinement in Isabelle/HOL. The framework is based on a nondeterminism-monad with assertions, i.e., the monad carries a set of results or an assertion failure. Recursion is expressed by fixed points. For convenience, we also provide while and foreach combinators.

The framework provides tools to automatize canonical tasks, such as verification condition generation, finding appropriate data refinement relations, and refine an executable program to a form that is accepted by the Isabelle/HOL code generator.

This submission comes with a collection of examples and a user-guide, illustrating the usage of the framework. extra-history = Change history: [2012-04-23] Introduced ordered FOREACH loops
[2012-06] New features: REC_rule_arb and RECT_rule_arb allow for generalizing over variables. prepare_code_thms - command extracts code equations for recursion combinators.
[2012-07] New example: Nested DFS for emptiness check of Buchi-automata with witness.
New feature: fo_rule method to apply resolution using first-order matching. Useful for arg_conf, fun_cong.
[2012-08] Adaptation to ICF v2.
[2012-10-05] Adaptations to include support for Automatic Refinement Framework.
[2013-09] This entry now depends on Automatic Refinement
[2014-06] New feature: vc_solve method to solve verification conditions. Maintenace changes: VCG-rules for nfoldli, improved setup for FOREACH-loops.
[2014-07] Now defining recursion via flat domain. Dropped many single-valued prerequisites. Changed notion of data refinement. In single-valued case, this matches the old notion. In non-single valued case, the new notion allows for more convenient rules. In particular, the new definitions allow for projecting away ghost variables as a refinement step.
[2014-11] New features: le-or-fail relation (leof), modular reasoning about loop invariants. notify = lammich@in.tum.de [Refine_Imperative_HOL] title = The Imperative Refinement Framework author = Peter Lammich notify = lammich@in.tum.de date = 2016-08-08 topic = Computer science/Programming languages/Transformations,Computer science/Data structures abstract = We present the Imperative Refinement Framework (IRF), a tool that supports a stepwise refinement based approach to imperative programs. This entry is based on the material we presented in [ITP-2015, CPP-2016]. It uses the Monadic Refinement Framework as a frontend for the specification of the abstract programs, and Imperative/HOL as a backend to generate executable imperative programs. The IRF comes with tool support to synthesize imperative programs from more abstract, functional ones, using efficient imperative implementations for the abstract data structures. This entry also includes the Imperative Isabelle Collection Framework (IICF), which provides a library of re-usable imperative collection data structures. Moreover, this entry contains a quickstart guide and a reference manual, which provide an introduction to using the IRF for Isabelle/HOL experts. It also provids a collection of (partly commented) practical examples, some highlights being Dijkstra's Algorithm, Nested-DFS, and a generic worklist algorithm with subsumption. Finally, this entry contains benchmark scripts that compare the runtime of some examples against reference implementations of the algorithms in Java and C++. [ITP-2015] Peter Lammich: Refinement to Imperative/HOL. ITP 2015: 253--269 [CPP-2016] Peter Lammich: Refinement based verification of imperative data structures. CPP 2016: 27--36 [Automatic_Refinement] title = Automatic Data Refinement author = Peter Lammich topic = Computer science/Programming languages/Logics date = 2013-10-02 abstract = We present the Autoref tool for Isabelle/HOL, which automatically refines algorithms specified over abstract concepts like maps and sets to algorithms over concrete implementations like red-black-trees, and produces a refinement theorem. It is based on ideas borrowed from relational parametricity due to Reynolds and Wadler. The tool allows for rapid prototyping of verified, executable algorithms. Moreover, it can be configured to fine-tune the result to the user~s needs. Our tool is able to automatically instantiate generic algorithms, which greatly simplifies the implementation of executable data structures.

This AFP-entry provides the basic tool, which is then used by the Refinement and Collection Framework to provide automatic data refinement for the nondeterminism monad and various collection datastructures. notify = lammich@in.tum.de [EdmondsKarp_Maxflow] title = Formalizing the Edmonds-Karp Algorithm author = Peter Lammich , S. Reza Sefidgar<> notify = lammich@in.tum.de date = 2016-08-12 topic = Computer science/Algorithms/Graph abstract = We present a formalization of the Ford-Fulkerson method for computing the maximum flow in a network. Our formal proof closely follows a standard textbook proof, and is accessible even without being an expert in Isabelle/HOL--- the interactive theorem prover used for the formalization. We then use stepwise refinement to obtain the Edmonds-Karp algorithm, and formally prove a bound on its complexity. Further refinement yields a verified implementation, whose execution time compares well to an unverified reference implementation in Java. This entry is based on our ITP-2016 paper with the same title. [VerifyThis2018] title = VerifyThis 2018 - Polished Isabelle Solutions author = Peter Lammich , Simon Wimmer topic = Computer science/Algorithms date = 2018-04-27 notify = lammich@in.tum.de abstract = VerifyThis 2018 was a program verification competition associated with ETAPS 2018. It was the 7th event in the VerifyThis competition series. In this entry, we present polished and completed versions of our solutions that we created during the competition. [PseudoHoops] title = Pseudo Hoops author = George Georgescu <>, Laurentiu Leustean <>, Viorel Preoteasa topic = Mathematics/Algebra date = 2011-09-22 abstract = Pseudo-hoops are algebraic structures introduced by B. Bosbach under the name of complementary semigroups. In this formalization we prove some properties of pseudo-hoops and we define the basic concepts of filter and normal filter. The lattice of normal filters is isomorphic with the lattice of congruences of a pseudo-hoop. We also study some important classes of pseudo-hoops. Bounded Wajsberg pseudo-hoops are equivalent to pseudo-Wajsberg algebras and bounded basic pseudo-hoops are equivalent to pseudo-BL algebras. Some examples of pseudo-hoops are given in the last section of the formalization. notify = viorel.preoteasa@aalto.fi [MonoBoolTranAlgebra] title = Algebra of Monotonic Boolean Transformers author = Viorel Preoteasa topic = Computer science/Programming languages/Logics date = 2011-09-22 abstract = Algebras of imperative programming languages have been successful in reasoning about programs. In general an algebra of programs is an algebraic structure with programs as elements and with program compositions (sequential composition, choice, skip) as algebra operations. Various versions of these algebras were introduced to model partial correctness, total correctness, refinement, demonic choice, and other aspects. We formalize here an algebra which can be used to model total correctness, refinement, demonic and angelic choice. The basic model of this algebra are monotonic Boolean transformers (monotonic functions from a Boolean algebra to itself). notify = viorel.preoteasa@aalto.fi [LatticeProperties] title = Lattice Properties author = Viorel Preoteasa topic = Mathematics/Order date = 2011-09-22 abstract = This formalization introduces and collects some algebraic structures based on lattices and complete lattices for use in other developments. The structures introduced are modular, and lattice ordered groups. In addition to the results proved for the new lattices, this formalization also introduces theorems about latices and complete lattices in general. extra-history = Change history: [2012-01-05]: Removed the theory about distributive complete lattices which is in the standard library now. Added a theory about well founded and transitive relations and a result about fixpoints in complete lattices and well founded relations. Moved the results about conjunctive and disjunctive functions to a new theory. Removed the syntactic classes for inf and sup which are in the standard library now. notify = viorel.preoteasa@aalto.fi [Impossible_Geometry] title = Proving the Impossibility of Trisecting an Angle and Doubling the Cube author = Ralph Romanos , Lawrence C. Paulson topic = Mathematics/Algebra, Mathematics/Geometry date = 2012-08-05 abstract = Squaring the circle, doubling the cube and trisecting an angle, using a compass and straightedge alone, are classic unsolved problems first posed by the ancient Greeks. All three problems were proved to be impossible in the 19th century. The following document presents the proof of the impossibility of solving the latter two problems using Isabelle/HOL, following a proof by Carrega. The proof uses elementary methods: no Galois theory or field extensions. The set of points constructible using a compass and straightedge is defined inductively. Radical expressions, which involve only square roots and arithmetic of rational numbers, are defined, and we find that all constructive points have radical coordinates. Finally, doubling the cube and trisecting certain angles requires solving certain cubic equations that can be proved to have no rational roots. The Isabelle proofs require a great many detailed calculations. notify = ralph.romanos@student.ecp.fr, lp15@cam.ac.uk [IP_Addresses] title = IP Addresses author = Cornelius Diekmann , Julius Michaelis , Lars Hupel notify = diekmann@net.in.tum.de date = 2016-06-28 topic = Computer science/Networks abstract = This entry contains a definition of IP addresses and a library to work with them. Generic IP addresses are modeled as machine words of arbitrary length. Derived from this generic definition, IPv4 addresses are 32bit machine words, IPv6 addresses are 128bit words. Additionally, IPv4 addresses can be represented in dot-decimal notation and IPv6 addresses in (compressed) colon-separated notation. We support toString functions and parsers for both notations. Sets of IP addresses can be represented with a netmask (e.g. 192.168.0.0/255.255.0.0) or in CIDR notation (e.g. 192.168.0.0/16). To provide executable code for set operations on IP address ranges, the library includes a datatype to work on arbitrary intervals of machine words. [Simple_Firewall] title = Simple Firewall author = Cornelius Diekmann , Julius Michaelis , Maximilian Haslbeck notify = diekmann@net.in.tum.de, max.haslbeck@gmx.de date = 2016-08-24 topic = Computer science/Networks abstract = We present a simple model of a firewall. The firewall can accept or drop a packet and can match on interfaces, IP addresses, protocol, and ports. It was designed to feature nice mathematical properties: The type of match expressions was carefully crafted such that the conjunction of two match expressions is only one match expression. This model is too simplistic to mirror all aspects of the real world. In the upcoming entry "Iptables Semantics", we will translate the Linux firewall iptables to this model. For a fixed service (e.g. ssh, http), we provide an algorithm to compute an overview of the firewall's filtering behavior. The algorithm computes minimal service matrices, i.e. graphs which partition the complete IPv4 and IPv6 address space and visualize the allowed accesses between partitions. For a detailed description, see Verified iptables Firewall Analysis, IFIP Networking 2016. [Iptables_Semantics] title = Iptables Semantics author = Cornelius Diekmann , Lars Hupel notify = diekmann@net.in.tum.de, hupel@in.tum.de date = 2016-09-09 topic = Computer science/Networks abstract = We present a big step semantics of the filtering behavior of the Linux/netfilter iptables firewall. We provide algorithms to simplify complex iptables rulests to a simple firewall model (c.f. AFP entry Simple_Firewall) and to verify spoofing protection of a ruleset. Internally, we embed our semantics into ternary logic, ultimately supporting every iptables match condition by abstracting over unknowns. Using this AFP entry and all entries it depends on, we created an easy-to-use, stand-alone haskell tool called fffuu. The tool does not require any input —except for the iptables-save dump of the analyzed firewall— and presents interesting results about the user's ruleset. Real-Word firewall errors have been uncovered, and the correctness of rulesets has been proved, with the help of our tool. [Routing] title = Routing author = Julius Michaelis , Cornelius Diekmann notify = afp@liftm.de date = 2016-08-31 topic = Computer science/Networks abstract = This entry contains definitions for routing with routing tables/longest prefix matching. A routing table entry is modelled as a record of a prefix match, a metric, an output port, and an optional next hop. A routing table is a list of entries, sorted by prefix length and metric. Additionally, a parser and serializer for the output of the ip-route command, a function to create a relation from output port to corresponding destination IP space, and a model of a Linux-style router are included. [KBPs] title = Knowledge-based programs author = Peter Gammie topic = Computer science/Automata and formal languages date = 2011-05-17 abstract = Knowledge-based programs (KBPs) are a formalism for directly relating agents' knowledge and behaviour. Here we present a general scheme for compiling KBPs to executable automata with a proof of correctness in Isabelle/HOL. We develop the algorithm top-down, using Isabelle's locale mechanism to structure these proofs, and show that two classic examples can be synthesised using Isabelle's code generator. extra-history = Change history: [2012-03-06]: Add some more views and revive the code generation. notify = kleing@cse.unsw.edu.au [Tarskis_Geometry] title = The independence of Tarski's Euclidean axiom author = T. J. M. Makarios topic = Mathematics/Geometry date = 2012-10-30 abstract = Tarski's axioms of plane geometry are formalized and, using the standard real Cartesian model, shown to be consistent. A substantial theory of the projective plane is developed. Building on this theory, the Klein-Beltrami model of the hyperbolic plane is defined and shown to satisfy all of Tarski's axioms except his Euclidean axiom; thus Tarski's Euclidean axiom is shown to be independent of his other axioms of plane geometry.

An earlier version of this work was the subject of the author's MSc thesis, which contains natural-language explanations of some of the more interesting proofs. notify = tjm1983@gmail.com [General-Triangle] title = The General Triangle Is Unique author = Joachim Breitner topic = Mathematics/Geometry date = 2011-04-01 abstract = Some acute-angled triangles are special, e.g. right-angled or isoscele triangles. Some are not of this kind, but, without measuring angles, look as if they were. In that sense, there is exactly one general triangle. This well-known fact is proven here formally. notify = mail@joachim-breitner.de [LightweightJava] title = Lightweight Java author = Rok Strniša , Matthew Parkinson topic = Computer science/Programming languages/Language definitions date = 2011-02-07 abstract = A fully-formalized and extensible minimal imperative fragment of Java. notify = rok@strnisa.com [Lower_Semicontinuous] title = Lower Semicontinuous Functions author = Bogdan Grechuk topic = Mathematics/Analysis date = 2011-01-08 abstract = We define the notions of lower and upper semicontinuity for functions from a metric space to the extended real line. We prove that a function is both lower and upper semicontinuous if and only if it is continuous. We also give several equivalent characterizations of lower semicontinuity. In particular, we prove that a function is lower semicontinuous if and only if its epigraph is a closed set. Also, we introduce the notion of the lower semicontinuous hull of an arbitrary function and prove its basic properties. notify = hoelzl@in.tum.de [RIPEMD-160-SPARK] title = RIPEMD-160 author = Fabian Immler topic = Computer science/Programming languages/Static analysis date = 2011-01-10 abstract = This work presents a verification of an implementation in SPARK/ADA of the cryptographic hash-function RIPEMD-160. A functional specification of RIPEMD-160 is given in Isabelle/HOL. Proofs for the verification conditions generated by the static-analysis toolset of SPARK certify the functional correctness of the implementation. extra-history = Change history: [2015-11-09]: Entry is now obsolete, moved to Isabelle distribution. notify = immler@in.tum.de [Regular-Sets] title = Regular Sets and Expressions author = Alexander Krauss , Tobias Nipkow contributors = Manuel Eberl topic = Computer science/Automata and formal languages date = 2010-05-12 abstract = This is a library of constructions on regular expressions and languages. It provides the operations of concatenation, Kleene star and derivative on languages. Regular expressions and their meaning are defined. An executable equivalence checker for regular expressions is verified; it does not need automata but works directly on regular expressions. By mapping regular expressions to binary relations, an automatic and complete proof method for (in)equalities of binary relations over union, concatenation and (reflexive) transitive closure is obtained.

Extended regular expressions with complement and intersection are also defined and an equivalence checker is provided. extra-history = Change history: [2011-08-26]: Christian Urban added a theory about derivatives and partial derivatives of regular expressions
[2012-05-10]: Tobias Nipkow added extended regular expressions
[2012-05-10]: Tobias Nipkow added equivalence checking with partial derivatives notify = nipkow@in.tum.de, krauss@in.tum.de, christian.urban@kcl.ac.uk [Regex_Equivalence] title = Unified Decision Procedures for Regular Expression Equivalence author = Tobias Nipkow , Dmitriy Traytel topic = Computer science/Automata and formal languages date = 2014-01-30 abstract = We formalize a unified framework for verified decision procedures for regular expression equivalence. Five recently published formalizations of such decision procedures (three based on derivatives, two on marked regular expressions) can be obtained as instances of the framework. We discover that the two approaches based on marked regular expressions, which were previously thought to be the same, are different, and one seems to produce uniformly smaller automata. The common framework makes it possible to compare the performance of the different decision procedures in a meaningful way. The formalization is described in a paper of the same name presented at Interactive Theorem Proving 2014. notify = nipkow@in.tum.de, traytel@in.tum.de [MSO_Regex_Equivalence] title = Decision Procedures for MSO on Words Based on Derivatives of Regular Expressions author = Dmitriy Traytel , Tobias Nipkow topic = Computer science/Automata and formal languages, Logic/General logic/Decidability of theories date = 2014-06-12 abstract = Monadic second-order logic on finite words (MSO) is a decidable yet expressive logic into which many decision problems can be encoded. Since MSO formulas correspond to regular languages, equivalence of MSO formulas can be reduced to the equivalence of some regular structures (e.g. automata). We verify an executable decision procedure for MSO formulas that is not based on automata but on regular expressions.

Decision procedures for regular expression equivalence have been formalized before, usually based on Brzozowski derivatives. Yet, for a straightforward embedding of MSO formulas into regular expressions an extension of regular expressions with a projection operation is required. We prove total correctness and completeness of an equivalence checker for regular expressions extended in that way. We also define a language-preserving translation of formulas into regular expressions with respect to two different semantics of MSO.

The formalization is described in this ICFP 2013 functional pearl. notify = traytel@in.tum.de, nipkow@in.tum.de [Formula_Derivatives] title = Derivatives of Logical Formulas author = Dmitriy Traytel topic = Computer science/Automata and formal languages, Logic/General logic/Decidability of theories date = 2015-05-28 abstract = We formalize new decision procedures for WS1S, M2L(Str), and Presburger Arithmetics. Formulas of these logics denote regular languages. Unlike traditional decision procedures, we do not translate formulas into automata (nor into regular expressions), at least not explicitly. Instead we devise notions of derivatives (inspired by Brzozowski derivatives for regular expressions) that operate on formulas directly and compute a syntactic bisimulation using these derivatives. The treatment of Boolean connectives and quantifiers is uniform for all mentioned logics and is abstracted into a locale. This locale is then instantiated by different atomic formulas and their derivatives (which may differ even for the same logic under different encodings of interpretations as formal words).

The WS1S instance is described in the draft paper A Coalgebraic Decision Procedure for WS1S by the author. notify = traytel@in.tum.de [Myhill-Nerode] title = The Myhill-Nerode Theorem Based on Regular Expressions author = Chunhan Wu <>, Xingyuan Zhang <>, Christian Urban contributors = Manuel Eberl topic = Computer science/Automata and formal languages date = 2011-08-26 abstract = There are many proofs of the Myhill-Nerode theorem using automata. In this library we give a proof entirely based on regular expressions, since regularity of languages can be conveniently defined using regular expressions (it is more painful in HOL to define regularity in terms of automata). We prove the first direction of the Myhill-Nerode theorem by solving equational systems that involve regular expressions. For the second direction we give two proofs: one using tagging-functions and another using partial derivatives. We also establish various closure properties of regular languages. Most details of the theories are described in our ITP 2011 paper. notify = christian.urban@kcl.ac.uk [Universal_Turing_Machine] title = Universal Turing Machine author = Jian Xu<>, Xingyuan Zhang<>, Christian Urban , Sebastiaan J. C. Joosten topic = Logic/Computability, Computer science/Automata and formal languages date = 2019-02-08 notify = sjcjoosten@gmail.com, christian.urban@kcl.ac.uk abstract = We formalise results from computability theory: recursive functions, undecidability of the halting problem, and the existence of a universal Turing machine. This formalisation is the AFP entry corresponding to the paper Mechanising Turing Machines and Computability Theory in Isabelle/HOL, ITP 2013. [CYK] title = A formalisation of the Cocke-Younger-Kasami algorithm author = Maksym Bortin date = 2016-04-27 topic = Computer science/Algorithms, Computer science/Automata and formal languages abstract = The theory provides a formalisation of the Cocke-Younger-Kasami algorithm (CYK for short), an approach to solving the word problem for context-free languages. CYK decides if a word is in the languages generated by a context-free grammar in Chomsky normal form. The formalized algorithm is executable. notify = maksym.bortin@nicta.com.au [Boolean_Expression_Checkers] title = Boolean Expression Checkers author = Tobias Nipkow date = 2014-06-08 topic = Computer science/Algorithms, Logic/General logic/Mechanization of proofs abstract = This entry provides executable checkers for the following properties of boolean expressions: satisfiability, tautology and equivalence. Internally, the checkers operate on binary decision trees and are reasonably efficient (for purely functional algorithms). extra-history = Change history: [2015-09-23]: Salomon Sickert added an interface that does not require the usage of the Boolean formula datatype. Furthermore the general Mapping type is used instead of an association list. notify = nipkow@in.tum.de [Presburger-Automata] title = Formalizing the Logic-Automaton Connection author = Stefan Berghofer , Markus Reiter <> date = 2009-12-03 topic = Computer science/Automata and formal languages, Logic/General logic/Decidability of theories abstract = This work presents a formalization of a library for automata on bit strings. It forms the basis of a reflection-based decision procedure for Presburger arithmetic, which is efficiently executable thanks to Isabelle's code generator. With this work, we therefore provide a mechanized proof of a well-known connection between logic and automata theory. The formalization is also described in a publication [TPHOLs 2009]. notify = berghofe@in.tum.de [Functional-Automata] title = Functional Automata author = Tobias Nipkow date = 2004-03-30 topic = Computer science/Automata and formal languages abstract = This theory defines deterministic and nondeterministic automata in a functional representation: the transition function/relation and the finality predicate are just functions. Hence the state space may be infinite. It is shown how to convert regular expressions into such automata. A scanner (generator) is implemented with the help of functional automata: the scanner chops the input up into longest recognized substrings. Finally we also show how to convert a certain subclass of functional automata (essentially the finite deterministic ones) into regular sets. notify = nipkow@in.tum.de [Statecharts] title = Formalizing Statecharts using Hierarchical Automata author = Steffen Helke , Florian Kammüller topic = Computer science/Automata and formal languages date = 2010-08-08 abstract = We formalize in Isabelle/HOL the abtract syntax and a synchronous step semantics for the specification language Statecharts. The formalization is based on Hierarchical Automata which allow a structural decomposition of Statecharts into Sequential Automata. To support the composition of Statecharts, we introduce calculating operators to construct a Hierarchical Automaton in a stepwise manner. Furthermore, we present a complete semantics of Statecharts including a theory of data spaces, which enables the modelling of racing effects. We also adapt CTL for Statecharts to build a bridge for future combinations with model checking. However the main motivation of this work is to provide a sound and complete basis for reasoning on Statecharts. As a central meta theorem we prove that the well-formedness of a Statechart is preserved by the semantics. notify = nipkow@in.tum.de [Stuttering_Equivalence] title = Stuttering Equivalence author = Stephan Merz topic = Computer science/Automata and formal languages date = 2012-05-07 abstract =

Two omega-sequences are stuttering equivalent if they differ only by finite repetitions of elements. Stuttering equivalence is a fundamental concept in the theory of concurrent and distributed systems. Notably, Lamport argues that refinement notions for such systems should be insensitive to finite stuttering. Peled and Wilke showed that all PLTL (propositional linear-time temporal logic) properties that are insensitive to stuttering equivalence can be expressed without the next-time operator. Stuttering equivalence is also important for certain verification techniques such as partial-order reduction for model checking.

We formalize stuttering equivalence in Isabelle/HOL. Our development relies on the notion of stuttering sampling functions that may skip blocks of identical sequence elements. We also encode PLTL and prove the theorem due to Peled and Wilke.

extra-history = Change history: [2013-01-31]: Added encoding of PLTL and proved Peled and Wilke's theorem. Adjusted abstract accordingly. notify = Stephan.Merz@loria.fr [Coinductive_Languages] title = A Codatatype of Formal Languages author = Dmitriy Traytel topic = Computer science/Automata and formal languages date = 2013-11-15 abstract =

We define formal languages as a codataype of infinite trees branching over the alphabet. Each node in such a tree indicates whether the path to this node constitutes a word inside or outside of the language. This codatatype is isormorphic to the set of lists representation of languages, but caters for definitions by corecursion and proofs by coinduction.

Regular operations on languages are then defined by primitive corecursion. A difficulty arises here, since the standard definitions of concatenation and iteration from the coalgebraic literature are not primitively corecursive-they require guardedness up-to union/concatenation. Without support for up-to corecursion, these operation must be defined as a composition of primitive ones (and proved being equal to the standard definitions). As an exercise in coinduction we also prove the axioms of Kleene algebra for the defined regular operations.

Furthermore, a language for context-free grammars given by productions in Greibach normal form and an initial nonterminal is constructed by primitive corecursion, yielding an executable decision procedure for the word problem without further ado.

notify = traytel@in.tum.de [Tree-Automata] title = Tree Automata author = Peter Lammich date = 2009-11-25 topic = Computer science/Automata and formal languages abstract = This work presents a machine-checked tree automata library for Standard-ML, OCaml and Haskell. The algorithms are efficient by using appropriate data structures like RB-trees. The available algorithms for non-deterministic automata include membership query, reduction, intersection, union, and emptiness check with computation of a witness for non-emptiness. The executable algorithms are derived from less-concrete, non-executable algorithms using data-refinement techniques. The concrete data structures are from the Isabelle Collections Framework. Moreover, this work contains a formalization of the class of tree-regular languages and its closure properties under set operations. notify = peter.lammich@uni-muenster.de, nipkow@in.tum.de [Depth-First-Search] title = Depth First Search author = Toshiaki Nishihara <>, Yasuhiko Minamide <> date = 2004-06-24 topic = Computer science/Algorithms/Graph abstract = Depth-first search of a graph is formalized with recdef. It is shown that it visits all of the reachable nodes from a given list of nodes. Executable ML code of depth-first search is obtained using the code generation feature of Isabelle/HOL. notify = lp15@cam.ac.uk, krauss@in.tum.de [FFT] title = Fast Fourier Transform author = Clemens Ballarin date = 2005-10-12 topic = Computer science/Algorithms/Mathematical abstract = We formalise a functional implementation of the FFT algorithm over the complex numbers, and its inverse. Both are shown equivalent to the usual definitions of these operations through Vandermonde matrices. They are also shown to be inverse to each other, more precisely, that composition of the inverse and the transformation yield the identity up to a scalar. notify = ballarin@in.tum.de [Gauss-Jordan-Elim-Fun] title = Gauss-Jordan Elimination for Matrices Represented as Functions author = Tobias Nipkow date = 2011-08-19 topic = Computer science/Algorithms/Mathematical, Mathematics/Algebra abstract = This theory provides a compact formulation of Gauss-Jordan elimination for matrices represented as functions. Its distinctive feature is succinctness. It is not meant for large computations. notify = nipkow@in.tum.de [UpDown_Scheme] title = Verification of the UpDown Scheme author = Johannes Hölzl date = 2015-01-28 topic = Computer science/Algorithms/Mathematical abstract = The UpDown scheme is a recursive scheme used to compute the stiffness matrix on a special form of sparse grids. Usually, when discretizing a Euclidean space of dimension d we need O(n^d) points, for n points along each dimension. Sparse grids are a hierarchical representation where the number of points is reduced to O(n * log(n)^d). One disadvantage of such sparse grids is that the algorithm now operate recursively in the dimensions and levels of the sparse grid.

The UpDown scheme allows us to compute the stiffness matrix on such a sparse grid. The stiffness matrix represents the influence of each representation function on the L^2 scalar product. For a detailed description see Dirk Pflüger's PhD thesis. This formalization was developed as an interdisciplinary project (IDP) at the Technische Universität München. notify = hoelzl@in.tum.de [GraphMarkingIBP] title = Verification of the Deutsch-Schorr-Waite Graph Marking Algorithm using Data Refinement author = Viorel Preoteasa , Ralph-Johan Back date = 2010-05-28 topic = Computer science/Algorithms/Graph abstract = The verification of the Deutsch-Schorr-Waite graph marking algorithm is used as a benchmark in many formalizations of pointer programs. The main purpose of this mechanization is to show how data refinement of invariant based programs can be used in verifying practical algorithms. The verification starts with an abstract algorithm working on a graph given by a relation next on nodes. Gradually the abstract program is refined into Deutsch-Schorr-Waite graph marking algorithm where only one bit per graph node of additional memory is used for marking. extra-history = Change history: [2012-01-05]: Updated for the new definition of data refinement and the new syntax for demonic and angelic update statements notify = viorel.preoteasa@aalto.fi [Efficient-Mergesort] title = Efficient Mergesort topic = Computer science/Algorithms date = 2011-11-09 author = Christian Sternagel abstract = We provide a formalization of the mergesort algorithm as used in GHC's Data.List module, proving correctness and stability. Furthermore, experimental data suggests that generated (Haskell-)code for this algorithm is much faster than for previous algorithms available in the Isabelle distribution. extra-history = Change history: [2012-10-24]: Added reference to journal article.
[2018-09-17]: Added theory Efficient_Mergesort that works exclusively with the mutual induction schemas generated by the function package.
[2018-09-19]: Added theory Mergesort_Complexity that proves an upper bound on the number of comparisons that are required by mergesort.
[2018-09-19]: Theory Efficient_Mergesort replaces theory Efficient_Sort but keeping the old name Efficient_Sort. notify = c.sternagel@gmail.com [SATSolverVerification] title = Formal Verification of Modern SAT Solvers author = Filip Marić date = 2008-07-23 topic = Computer science/Algorithms abstract = This document contains formal correctness proofs of modern SAT solvers. Following (Krstic et al, 2007) and (Nieuwenhuis et al., 2006), solvers are described using state-transition systems. Several different SAT solver descriptions are given and their partial correctness and termination is proved. These include:

  • a solver based on classical DPLL procedure (using only a backtrack-search with unit propagation),
  • a very general solver with backjumping and learning (similar to the description given in (Nieuwenhuis et al., 2006)), and
  • a solver with a specific conflict analysis algorithm (similar to the description given in (Krstic et al., 2007)).
Within the SAT solver correctness proofs, a large number of lemmas about propositional logic and CNF formulae are proved. This theory is self-contained and could be used for further exploring of properties of CNF based SAT algorithms. notify = [Transitive-Closure] title = Executable Transitive Closures of Finite Relations topic = Computer science/Algorithms/Graph date = 2011-03-14 author = Christian Sternagel , René Thiemann license = LGPL abstract = We provide a generic work-list algorithm to compute the transitive closure of finite relations where only successors of newly detected states are generated. This algorithm is then instantiated for lists over arbitrary carriers and red black trees (which are faster but require a linear order on the carrier), respectively. Our formalization was performed as part of the IsaFoR/CeTA project where reflexive transitive closures of large tree automata have to be computed. extra-history = Change history: [2014-09-04] added example simprocs in Finite_Transitive_Closure_Simprocs notify = c.sternagel@gmail.com, rene.thiemann@uibk.ac.at [Transitive-Closure-II] title = Executable Transitive Closures topic = Computer science/Algorithms/Graph date = 2012-02-29 author = René Thiemann license = LGPL abstract =

We provide a generic work-list algorithm to compute the (reflexive-)transitive closure of relations where only successors of newly detected states are generated. In contrast to our previous work, the relations do not have to be finite, but each element must only have finitely many (indirect) successors. Moreover, a subsumption relation can be used instead of pure equality. An executable variant of the algorithm is available where the generic operations are instantiated with list operations.

This formalization was performed as part of the IsaFoR/CeTA project, and it has been used to certify size-change termination proofs where large transitive closures have to be computed.

notify = rene.thiemann@uibk.ac.at [MuchAdoAboutTwo] title = Much Ado About Two author = Sascha Böhme date = 2007-11-06 topic = Computer science/Algorithms abstract = This article is an Isabelle formalisation of a paper with the same title. In a similar way as Knuth's 0-1-principle for sorting algorithms, that paper develops a 0-1-2-principle for parallel prefix computations. notify = boehmes@in.tum.de [DiskPaxos] title = Proving the Correctness of Disk Paxos date = 2005-06-22 author = Mauro Jaskelioff , Stephan Merz topic = Computer science/Algorithms/Distributed abstract = Disk Paxos is an algorithm for building arbitrary fault-tolerant distributed systems. The specification of Disk Paxos has been proved correct informally and tested using the TLC model checker, but up to now, it has never been fully formally verified. In this work we have formally verified its correctness using the Isabelle theorem prover and the HOL logic system, showing that Isabelle is a practical tool for verifying properties of TLA+ specifications. notify = kleing@cse.unsw.edu.au [GenClock] title = Formalization of a Generalized Protocol for Clock Synchronization author = Alwen Tiu date = 2005-06-24 topic = Computer science/Algorithms/Distributed abstract = We formalize the generalized Byzantine fault-tolerant clock synchronization protocol of Schneider. This protocol abstracts from particular algorithms or implementations for clock synchronization. This abstraction includes several assumptions on the behaviors of physical clocks and on general properties of concrete algorithms/implementations. Based on these assumptions the correctness of the protocol is proved by Schneider. His proof was later verified by Shankar using the theorem prover EHDM (precursor to PVS). Our formalization in Isabelle/HOL is based on Shankar's formalization. notify = kleing@cse.unsw.edu.au [ClockSynchInst] title = Instances of Schneider's generalized protocol of clock synchronization author = Damián Barsotti date = 2006-03-15 topic = Computer science/Algorithms/Distributed abstract = F. B. Schneider ("Understanding protocols for Byzantine clock synchronization") generalizes a number of protocols for Byzantine fault-tolerant clock synchronization and presents a uniform proof for their correctness. In Schneider's schema, each processor maintains a local clock by periodically adjusting each value to one computed by a convergence function applied to the readings of all the clocks. Then, correctness of an algorithm, i.e. that the readings of two clocks at any time are within a fixed bound of each other, is based upon some conditions on the convergence function. To prove that a particular clock synchronization algorithm is correct it suffices to show that the convergence function used by the algorithm meets Schneider's conditions. Using the theorem prover Isabelle, we formalize the proofs that the convergence functions of two algorithms, namely, the Interactive Convergence Algorithm (ICA) of Lamport and Melliar-Smith and the Fault-tolerant Midpoint algorithm of Lundelius-Lynch, meet Schneider's conditions. Furthermore, we experiment on handling some parts of the proofs with fully automatic tools like ICS and CVC-lite. These theories are part of a joint work with Alwen Tiu and Leonor P. Nieto "Verification of Clock Synchronization Algorithms: Experiments on a combination of deductive tools" in proceedings of AVOCS 2005. In this work the correctness of Schneider schema was also verified using Isabelle (entry GenClock in AFP). notify = kleing@cse.unsw.edu.au [Heard_Of] title = Verifying Fault-Tolerant Distributed Algorithms in the Heard-Of Model date = 2012-07-27 author = Henri Debrat , Stephan Merz topic = Computer science/Algorithms/Distributed abstract = Distributed computing is inherently based on replication, promising increased tolerance to failures of individual computing nodes or communication channels. Realizing this promise, however, involves quite subtle algorithmic mechanisms, and requires precise statements about the kinds and numbers of faults that an algorithm tolerates (such as process crashes, communication faults or corrupted values). The landmark theorem due to Fischer, Lynch, and Paterson shows that it is impossible to achieve Consensus among N asynchronously communicating nodes in the presence of even a single permanent failure. Existing solutions must rely on assumptions of "partial synchrony".

Indeed, there have been numerous misunderstandings on what exactly a given algorithm is supposed to realize in what kinds of environments. Moreover, the abundance of subtly different computational models complicates comparisons between different algorithms. Charron-Bost and Schiper introduced the Heard-Of model for representing algorithms and failure assumptions in a uniform framework, simplifying comparisons between algorithms.

In this contribution, we represent the Heard-Of model in Isabelle/HOL. We define two semantics of runs of algorithms with different unit of atomicity and relate these through a reduction theorem that allows us to verify algorithms in the coarse-grained semantics (where proofs are easier) and infer their correctness for the fine-grained one (which corresponds to actual executions). We instantiate the framework by verifying six Consensus algorithms that differ in the underlying algorithmic mechanisms and the kinds of faults they tolerate. notify = Stephan.Merz@loria.fr [Consensus_Refined] title = Consensus Refined date = 2015-03-18 author = Ognjen Maric <>, Christoph Sprenger topic = Computer science/Algorithms/Distributed abstract = Algorithms for solving the consensus problem are fundamental to distributed computing. Despite their brevity, their ability to operate in concurrent, asynchronous and failure-prone environments comes at the cost of complex and subtle behaviors. Accordingly, understanding how they work and proving their correctness is a non-trivial endeavor where abstraction is immensely helpful. Moreover, research on consensus has yielded a large number of algorithms, many of which appear to share common algorithmic ideas. A natural question is whether and how these similarities can be distilled and described in a precise, unified way. In this work, we combine stepwise refinement and lockstep models to provide an abstract and unified view of a sizeable family of consensus algorithms. Our models provide insights into the design choices underlying the different algorithms, and classify them based on those choices. notify = sprenger@inf.ethz.ch [Key_Agreement_Strong_Adversaries] title = Refining Authenticated Key Agreement with Strong Adversaries author = Joseph Lallemand , Christoph Sprenger topic = Computer science/Security license = LGPL date = 2017-01-31 notify = joseph.lallemand@loria.fr, sprenger@inf.ethz.ch abstract = We develop a family of key agreement protocols that are correct by construction. Our work substantially extends prior work on developing security protocols by refinement. First, we strengthen the adversary by allowing him to compromise different resources of protocol participants, such as their long-term keys or their session keys. This enables the systematic development of protocols that ensure strong properties such as perfect forward secrecy. Second, we broaden the class of protocols supported to include those with non-atomic keys and equationally defined cryptographic operators. We use these extensions to develop key agreement protocols including signed Diffie-Hellman and the core of IKEv1 and SKEME. [Security_Protocol_Refinement] title = Developing Security Protocols by Refinement author = Christoph Sprenger , Ivano Somaini<> topic = Computer science/Security license = LGPL date = 2017-05-24 notify = sprenger@inf.ethz.ch abstract = We propose a development method for security protocols based on stepwise refinement. Our refinement strategy transforms abstract security goals into protocols that are secure when operating over an insecure channel controlled by a Dolev-Yao-style intruder. As intermediate levels of abstraction, we employ messageless guard protocols and channel protocols communicating over channels with security properties. These abstractions provide insights on why protocols are secure and foster the development of families of protocols sharing common structure and properties. We have implemented our method in Isabelle/HOL and used it to develop different entity authentication and key establishment protocols, including realistic features such as key confirmation, replay caches, and encrypted tickets. Our development highlights that guard protocols and channel protocols provide fundamental abstractions for bridging the gap between security properties and standard protocol descriptions based on cryptographic messages. It also shows that our refinement approach scales to protocols of nontrivial size and complexity. [Abortable_Linearizable_Modules] title = Abortable Linearizable Modules author = Rachid Guerraoui , Viktor Kuncak , Giuliano Losa date = 2012-03-01 topic = Computer science/Algorithms/Distributed abstract = We define the Abortable Linearizable Module automaton (ALM for short) and prove its key composition property using the IOA theory of HOLCF. The ALM is at the heart of the Speculative Linearizability framework. This framework simplifies devising correct speculative algorithms by enabling their decomposition into independent modules that can be analyzed and proved correct in isolation. It is particularly useful when working in a distributed environment, where the need to tolerate faults and asynchrony has made current monolithic protocols so intricate that it is no longer tractable to check their correctness. Our theory contains a typical example of a refinement proof in the I/O-automata framework of Lynch and Tuttle. notify = giuliano@losa.fr, nipkow@in.tum.de [Amortized_Complexity] title = Amortized Complexity Verified author = Tobias Nipkow date = 2014-07-07 topic = Computer science/Data structures abstract = A framework for the analysis of the amortized complexity of functional data structures is formalized in Isabelle/HOL and applied to a number of standard examples and to the folowing non-trivial ones: skew heaps, splay trees, splay heaps and pairing heaps.

A preliminary version of this work (without pairing heaps) is described in a paper published in the proceedings of the conference on Interactive Theorem Proving ITP 2015. An extended version of this publication is available here. extra-history = Change history: [2015-03-17]: Added pairing heaps by Hauke Brinkop.
[2016-07-12]: Moved splay heaps from here to Splay_Tree
[2016-07-14]: Moved pairing heaps from here to the new Pairing_Heap notify = nipkow@in.tum.de [Dynamic_Tables] title = Parameterized Dynamic Tables author = Tobias Nipkow date = 2015-06-07 topic = Computer science/Data structures abstract = This article formalizes the amortized analysis of dynamic tables parameterized with their minimal and maximal load factors and the expansion and contraction factors.

A full description is found in a companion paper. notify = nipkow@in.tum.de [AVL-Trees] title = AVL Trees author = Tobias Nipkow , Cornelia Pusch <> date = 2004-03-19 topic = Computer science/Data structures abstract = Two formalizations of AVL trees with room for extensions. The first formalization is monolithic and shorter, the second one in two stages, longer and a bit simpler. The final implementation is the same. If you are interested in developing this further, please contact gerwin.klein@nicta.com.au. extra-history = Change history: [2011-04-11]: Ondrej Kuncar added delete function notify = kleing@cse.unsw.edu.au [BDD] title = BDD Normalisation author = Veronika Ortner <>, Norbert Schirmer <> date = 2008-02-29 topic = Computer science/Data structures abstract = We present the verification of the normalisation of a binary decision diagram (BDD). The normalisation follows the original algorithm presented by Bryant in 1986 and transforms an ordered BDD in a reduced, ordered and shared BDD. The verification is based on Hoare logics. notify = kleing@cse.unsw.edu.au, norbert.schirmer@web.de [BinarySearchTree] title = Binary Search Trees author = Viktor Kuncak date = 2004-04-05 topic = Computer science/Data structures abstract = The correctness is shown of binary search tree operations (lookup, insert and remove) implementing a set. Two versions are given, for both structured and linear (tactic-style) proofs. An implementation of integer-indexed maps is also verified. notify = lp15@cam.ac.uk [Splay_Tree] title = Splay Tree author = Tobias Nipkow notify = nipkow@in.tum.de date = 2014-08-12 topic = Computer science/Data structures abstract = Splay trees are self-adjusting binary search trees which were invented by Sleator and Tarjan [JACM 1985]. This entry provides executable and verified functional splay trees as well as the related splay heaps (due to Okasaki).

The amortized complexity of splay trees and heaps is analyzed in the AFP entry Amortized Complexity. extra-history = Change history: [2016-07-12]: Moved splay heaps here from Amortized_Complexity [Root_Balanced_Tree] title = Root-Balanced Tree author = Tobias Nipkow notify = nipkow@in.tum.de date = 2017-08-20 topic = Computer science/Data structures abstract =

Andersson introduced general balanced trees, search trees based on the design principle of partial rebuilding: perform update operations naively until the tree becomes too unbalanced, at which point a whole subtree is rebalanced. This article defines and analyzes a functional version of general balanced trees, which we call root-balanced trees. Using a lightweight model of execution time, amortized logarithmic complexity is verified in the theorem prover Isabelle.

This is the Isabelle formalization of the material decribed in the APLAS 2017 article Verified Root-Balanced Trees by the same author, which also presents experimental results that show competitiveness of root-balanced with AVL and red-black trees.

[Skew_Heap] title = Skew Heap author = Tobias Nipkow date = 2014-08-13 topic = Computer science/Data structures abstract = Skew heaps are an amazingly simple and lightweight implementation of priority queues. They were invented by Sleator and Tarjan [SIAM 1986] and have logarithmic amortized complexity. This entry provides executable and verified functional skew heaps.

The amortized complexity of skew heaps is analyzed in the AFP entry Amortized Complexity. notify = nipkow@in.tum.de [Pairing_Heap] title = Pairing Heap author = Hauke Brinkop , Tobias Nipkow date = 2016-07-14 topic = Computer science/Data structures abstract = This library defines three different versions of pairing heaps: a functional version of the original design based on binary trees [Fredman et al. 1986], the version by Okasaki [1998] and a modified version of the latter that is free of structural invariants.

The amortized complexity of pairing heaps is analyzed in the AFP article Amortized Complexity. extra-0 = Origin: This library was extracted from Amortized Complexity and extended. notify = nipkow@in.tum.de [Priority_Queue_Braun] title = Priority Queues Based on Braun Trees author = Tobias Nipkow date = 2014-09-04 topic = Computer science/Data structures abstract = This entry verifies priority queues based on Braun trees. Insertion and deletion take logarithmic time and preserve the balanced nature of Braun trees. Two implementations of deletion are provided. notify = nipkow@in.tum.de extra-history = Change history: [2019-12-16]: Added theory Priority_Queue_Braun2 with second version of del_min [Binomial-Queues] title = Functional Binomial Queues author = René Neumann date = 2010-10-28 topic = Computer science/Data structures abstract = Priority queues are an important data structure and efficient implementations of them are crucial. We implement a functional variant of binomial queues in Isabelle/HOL and show its functional correctness. A verification against an abstract reference specification of priority queues has also been attempted, but could not be achieved to the full extent. notify = florian.haftmann@informatik.tu-muenchen.de [Binomial-Heaps] title = Binomial Heaps and Skew Binomial Heaps author = Rene Meis , Finn Nielsen , Peter Lammich date = 2010-10-28 topic = Computer science/Data structures abstract = We implement and prove correct binomial heaps and skew binomial heaps. Both are data-structures for priority queues. While binomial heaps have logarithmic findMin, deleteMin, insert, and meld operations, skew binomial heaps have constant time findMin, insert, and meld operations, and only the deleteMin-operation is logarithmic. This is achieved by using skew links to avoid cascading linking on insert-operations, and data-structural bootstrapping to get constant-time findMin and meld operations. Our implementation follows the paper by Brodal and Okasaki. notify = peter.lammich@uni-muenster.de [Finger-Trees] title = Finger Trees author = Benedikt Nordhoff , Stefan Körner , Peter Lammich date = 2010-10-28 topic = Computer science/Data structures abstract = We implement and prove correct 2-3 finger trees. Finger trees are a general purpose data structure, that can be used to efficiently implement other data structures, such as priority queues. Intuitively, a finger tree is an annotated sequence, where the annotations are elements of a monoid. Apart from operations to access the ends of the sequence, the main operation is to split the sequence at the point where a monotone predicate over the sum of the left part of the sequence becomes true for the first time. The implementation follows the paper of Hinze and Paterson. The code generator can be used to get efficient, verified code. notify = peter.lammich@uni-muenster.de [Trie] title = Trie author = Andreas Lochbihler , Tobias Nipkow date = 2015-03-30 topic = Computer science/Data structures abstract = This article formalizes the ``trie'' data structure invented by Fredkin [CACM 1960]. It also provides a specialization where the entries in the trie are lists. extra-0 = Origin: This article was extracted from existing articles by the authors. notify = nipkow@in.tum.de [FinFun] title = Code Generation for Functions as Data author = Andreas Lochbihler date = 2009-05-06 topic = Computer science/Data structures abstract = FinFuns are total functions that are constant except for a finite set of points, i.e. a generalisation of finite maps. They are formalised as a new type in Isabelle/HOL such that the code generator can handle equality tests and quantification on FinFuns. On the code output level, FinFuns are explicitly represented by constant functions and pointwise updates, similarly to associative lists. Inside the logic, they behave like ordinary functions with extensionality. Via the update/constant pattern, a recursion combinator and an induction rule for FinFuns allow for defining and reasoning about operators on FinFun that are also executable. extra-history = Change history: [2010-08-13]: new concept domain of a FinFun as a FinFun (revision 34b3517cbc09)
[2010-11-04]: new conversion function from FinFun to list of elements in the domain (revision 0c167102e6ed)
[2012-03-07]: replace sets as FinFuns by predicates as FinFuns because the set type constructor has been reintroduced (revision b7aa87989f3a) notify = nipkow@in.tum.de [Collections] title = Collections Framework author = Peter Lammich contributors = Andreas Lochbihler , Thomas Tuerk <> date = 2009-11-25 topic = Computer science/Data structures abstract = This development provides an efficient, extensible, machine checked collections framework. The library adopts the concepts of interface, implementation and generic algorithm from object-oriented programming and implements them in Isabelle/HOL. The framework features the use of data refinement techniques to refine an abstract specification (using high-level concepts like sets) to a more concrete implementation (using collection datastructures, like red-black-trees). The code-generator of Isabelle/HOL can be used to generate efficient code. extra-history = Change history: [2010-10-08]: New Interfaces: OrderedSet, OrderedMap, List. Fifo now implements list-interface: Function names changed: put/get --> enqueue/dequeue. New Implementations: ArrayList, ArrayHashMap, ArrayHashSet, TrieMap, TrieSet. Invariant-free datastructures: Invariant implicitely hidden in typedef. Record-interfaces: All operations of an interface encapsulated as record. Examples moved to examples subdirectory.
[2010-12-01]: New Interfaces: Priority Queues, Annotated Lists. Implemented by finger trees, (skew) binomial queues.
[2011-10-10]: SetSpec: Added operations: sng, isSng, bexists, size_abort, diff, filter, iterate_rule_insertP MapSpec: Added operations: sng, isSng, iterate_rule_insertP, bexists, size, size_abort, restrict, map_image_filter, map_value_image_filter Some maintenance changes
[2012-04-25]: New iterator foundation by Tuerk. Various maintenance changes.
[2012-08]: Collections V2. New features: Polymorphic iterators. Generic algorithm instantiation where required. Naming scheme changed from xx_opname to xx.opname. A compatibility file CollectionsV1 tries to simplify porting of existing theories, by providing old naming scheme and the old monomorphic iterator locales.
[2013-09]: Added Generic Collection Framework based on Autoref. The GenCF provides: Arbitrary nesting, full integration with Autoref.
[2014-06]: Maintenace changes to GenCF: Optimized inj_image on list_set. op_set_cart (Cartesian product). big-Union operation. atLeastLessThan - operation ({a..<b})
notify = lammich@in.tum.de [Containers] title = Light-weight Containers author = Andreas Lochbihler contributors = René Thiemann date = 2013-04-15 topic = Computer science/Data structures abstract = This development provides a framework for container types like sets and maps such that generated code implements these containers with different (efficient) data structures. Thanks to type classes and refinement during code generation, this light-weight approach can seamlessly replace Isabelle's default setup for code generation. Heuristics automatically pick one of the available data structures depending on the type of elements to be stored, but users can also choose on their own. The extensible design permits to add more implementations at any time.

To support arbitrary nesting of sets, we define a linear order on sets based on a linear order of the elements and provide efficient implementations. It even allows to compare complements with non-complements. extra-history = Change history: [2013-07-11]: add pretty printing for sets (revision 7f3f52c5f5fa)
[2013-09-20]: provide generators for canonical type class instantiations (revision 159f4401f4a8 by René Thiemann)
[2014-07-08]: add support for going from partial functions to mappings (revision 7a6fc957e8ed)
[2018-03-05]: add two application examples: depth-first search and 2SAT (revision e5e1a1da2411) notify = mail@andreas-lochbihler.de [FileRefinement] title = File Refinement author = Karen Zee , Viktor Kuncak date = 2004-12-09 topic = Computer science/Data structures abstract = These theories illustrates the verification of basic file operations (file creation, file read and file write) in the Isabelle theorem prover. We describe a file at two levels of abstraction: an abstract file represented as a resizable array, and a concrete file represented using data blocks. notify = kkz@mit.edu [Datatype_Order_Generator] title = Generating linear orders for datatypes author = René Thiemann date = 2012-08-07 topic = Computer science/Data structures abstract = We provide a framework for registering automatic methods to derive class instances of datatypes, as it is possible using Haskell's ``deriving Ord, Show, ...'' feature.

We further implemented such automatic methods to derive (linear) orders or hash-functions which are required in the Isabelle Collection Framework. Moreover, for the tactic of Huffman and Krauss to show that a datatype is countable, we implemented a wrapper so that this tactic becomes accessible in our framework.

Our formalization was performed as part of the IsaFoR/CeTA project. With our new tactic we could completely remove tedious proofs for linear orders of two datatypes.

This development is aimed at datatypes generated by the "old_datatype" command. notify = rene.thiemann@uibk.ac.at [Deriving] title = Deriving class instances for datatypes author = Christian Sternagel , René Thiemann date = 2015-03-11 topic = Computer science/Data structures abstract =

We provide a framework for registering automatic methods to derive class instances of datatypes, as it is possible using Haskell's ``deriving Ord, Show, ...'' feature.

We further implemented such automatic methods to derive comparators, linear orders, parametrizable equality functions, and hash-functions which are required in the Isabelle Collection Framework and the Container Framework. Moreover, for the tactic of Blanchette to show that a datatype is countable, we implemented a wrapper so that this tactic becomes accessible in our framework. All of the generators are based on the infrastructure that is provided by the BNF-based datatype package.

Our formalization was performed as part of the IsaFoR/CeTA project. With our new tactics we could remove several tedious proofs for (conditional) linear orders, and conditional equality operators within IsaFoR and the Container Framework.

notify = rene.thiemann@uibk.ac.at [List-Index] title = List Index date = 2010-02-20 author = Tobias Nipkow topic = Computer science/Data structures abstract = This theory provides functions for finding the index of an element in a list, by predicate and by value. notify = nipkow@in.tum.de [List-Infinite] title = Infinite Lists date = 2011-02-23 author = David Trachtenherz <> topic = Computer science/Data structures abstract = We introduce a theory of infinite lists in HOL formalized as functions over naturals (folder ListInf, theories ListInf and ListInf_Prefix). It also provides additional results for finite lists (theory ListInf/List2), natural numbers (folder CommonArith, esp. division/modulo, naturals with infinity), sets (folder CommonSet, esp. cutting/truncating sets, traversing sets of naturals). notify = nipkow@in.tum.de [Matrix] title = Executable Matrix Operations on Matrices of Arbitrary Dimensions topic = Computer science/Data structures date = 2010-06-17 author = Christian Sternagel , René Thiemann license = LGPL abstract = We provide the operations of matrix addition, multiplication, transposition, and matrix comparisons as executable functions over ordered semirings. Moreover, it is proven that strongly normalizing (monotone) orders can be lifted to strongly normalizing (monotone) orders over matrices. We further show that the standard semirings over the naturals, integers, and rationals, as well as the arctic semirings satisfy the axioms that are required by our matrix theory. Our formalization is part of the CeTA system which contains several termination techniques. The provided theories have been essential to formalize matrix-interpretations and arctic interpretations. extra-history = Change history: [2010-09-17]: Moved theory on arbitrary (ordered) semirings to Abstract Rewriting. notify = rene.thiemann@uibk.ac.at, christian.sternagel@uibk.ac.at [Matrix_Tensor] title = Tensor Product of Matrices topic = Computer science/Data structures, Mathematics/Algebra date = 2016-01-18 author = T.V.H. Prathamesh abstract = In this work, the Kronecker tensor product of matrices and the proofs of some of its properties are formalized. Properties which have been formalized include associativity of the tensor product and the mixed-product property. notify = prathamesh@imsc.res.in [Huffman] title = The Textbook Proof of Huffman's Algorithm author = Jasmin Christian Blanchette date = 2008-10-15 topic = Computer science/Data structures abstract = Huffman's algorithm is a procedure for constructing a binary tree with minimum weighted path length. This report presents a formal proof of the correctness of Huffman's algorithm written using Isabelle/HOL. Our proof closely follows the sketches found in standard algorithms textbooks, uncovering a few snags in the process. Another distinguishing feature of our formalization is the use of custom induction rules to help Isabelle's automatic tactics, leading to very short proofs for most of the lemmas. notify = jasmin.blanchette@gmail.com [Partial_Function_MR] title = Mutually Recursive Partial Functions author = René Thiemann topic = Computer science/Functional programming date = 2014-02-18 license = LGPL abstract = We provide a wrapper around the partial-function command that supports mutual recursion. notify = rene.thiemann@uibk.ac.at [Lifting_Definition_Option] title = Lifting Definition Option author = René Thiemann topic = Computer science/Functional programming date = 2014-10-13 license = LGPL abstract = We implemented a command that can be used to easily generate elements of a restricted type {x :: 'a. P x}, provided the definition is of the form f ys = (if check ys then Some(generate ys :: 'a) else None) where ys is a list of variables y1 ... yn and check ys ==> P(generate ys) can be proved.

In principle, such a definition is also directly possible using the lift_definition command. However, then this definition will not be suitable for code-generation. To this end, we automated a more complex construction of Joachim Breitner which is amenable for code-generation, and where the test check ys will only be performed once. In the automation, one auxiliary type is created, and Isabelle's lifting- and transfer-package is invoked several times. notify = rene.thiemann@uibk.ac.at [Coinductive] title = Coinductive topic = Computer science/Functional programming author = Andreas Lochbihler contributors = Johannes Hölzl date = 2010-02-12 abstract = This article collects formalisations of general-purpose coinductive data types and sets. Currently, it contains coinductive natural numbers, coinductive lists, i.e. lazy lists or streams, infinite streams, coinductive terminated lists, coinductive resumptions, a library of operations on coinductive lists, and a version of König's lemma as an application for coinductive lists.
The initial theory was contributed by Paulson and Wenzel. Extensions and other coinductive formalisations of general interest are welcome. extra-history = Change history: [2010-06-10]: coinductive lists: setup for quotient package (revision 015574f3bf3c)
[2010-06-28]: new codatatype terminated lazy lists (revision e12de475c558)
[2010-08-04]: terminated lazy lists: setup for quotient package; more lemmas (revision 6ead626f1d01)
[2010-08-17]: Koenig's lemma as an example application for coinductive lists (revision f81ce373fa96)
[2011-02-01]: lazy implementation of coinductive (terminated) lists for the code generator (revision 6034973dce83)
[2011-07-20]: new codatatype resumption (revision 811364c776c7)
[2012-06-27]: new codatatype stream with operations (with contributions by Peter Gammie) (revision dd789a56473c)
[2013-03-13]: construct codatatypes with the BNF package and adjust the definitions and proofs, setup for lifting and transfer packages (revision f593eda5b2c0)
[2013-09-20]: stream theory uses type and operations from HOL/BNF/Examples/Stream (revision 692809b2b262)
[2014-04-03]: ccpo structure on codatatypes used to define ldrop, ldropWhile, lfilter, lconcat as least fixpoint; ccpo topology on coinductive lists contributed by Johannes Hölzl; added examples (revision 23cd8156bd42)
notify = mail@andreas-lochbihler.de [Stream-Fusion] title = Stream Fusion author = Brian Huffman topic = Computer science/Functional programming date = 2009-04-29 abstract = Stream Fusion is a system for removing intermediate list structures from Haskell programs; it consists of a Haskell library along with several compiler rewrite rules. (The library is available online.)

These theories contain a formalization of much of the Stream Fusion library in HOLCF. Lazy list and stream types are defined, along with coercions between the two types, as well as an equivalence relation for streams that generate the same list. List and stream versions of map, filter, foldr, enumFromTo, append, zipWith, and concatMap are defined, and the stream versions are shown to respect stream equivalence. notify = brianh@cs.pdx.edu [Tycon] title = Type Constructor Classes and Monad Transformers author = Brian Huffman date = 2012-06-26 topic = Computer science/Functional programming abstract = These theories contain a formalization of first class type constructors and axiomatic constructor classes for HOLCF. This work is described in detail in the ICFP 2012 paper Formal Verification of Monad Transformers by the author. The formalization is a revised and updated version of earlier joint work with Matthews and White.

Based on the hierarchy of type classes in Haskell, we define classes for functors, monads, monad-plus, etc. Each one includes all the standard laws as axioms. We also provide a new user command, tycondef, for defining new type constructors in HOLCF. Using tycondef, we instantiate the type class hierarchy with various monads and monad transformers. notify = huffman@in.tum.de [CoreC++] title = CoreC++ author = Daniel Wasserrab date = 2006-05-15 topic = Computer science/Programming languages/Language definitions abstract = We present an operational semantics and type safety proof for multiple inheritance in C++. The semantics models the behavior of method calls, field accesses, and two forms of casts in C++ class hierarchies. For explanations see the OOPSLA 2006 paper by Wasserrab, Nipkow, Snelting and Tip. notify = nipkow@in.tum.de [FeatherweightJava] title = A Theory of Featherweight Java in Isabelle/HOL author = J. Nathan Foster , Dimitrios Vytiniotis date = 2006-03-31 topic = Computer science/Programming languages/Language definitions abstract = We formalize the type system, small-step operational semantics, and type soundness proof for Featherweight Java, a simple object calculus, in Isabelle/HOL. notify = kleing@cse.unsw.edu.au [Jinja] title = Jinja is not Java author = Gerwin Klein , Tobias Nipkow date = 2005-06-01 topic = Computer science/Programming languages/Language definitions abstract = We introduce Jinja, a Java-like programming language with a formal semantics designed to exhibit core features of the Java language architecture. Jinja is a compromise between realism of the language and tractability and clarity of the formal semantics. The following aspects are formalised: a big and a small step operational semantics for Jinja and a proof of their equivalence; a type system and a definite initialisation analysis; a type safety proof of the small step semantics; a virtual machine (JVM), its operational semantics and its type system; a type safety proof for the JVM; a bytecode verifier, i.e. data flow analyser for the JVM; a correctness proof of the bytecode verifier w.r.t. the type system; a compiler and a proof that it preserves semantics and well-typedness. The emphasis of this work is not on particular language features but on providing a unified model of the source language, the virtual machine and the compiler. The whole development has been carried out in the theorem prover Isabelle/HOL. notify = kleing@cse.unsw.edu.au, nipkow@in.tum.de [JinjaThreads] title = Jinja with Threads author = Andreas Lochbihler date = 2007-12-03 topic = Computer science/Programming languages/Language definitions abstract = We extend the Jinja source code semantics by Klein and Nipkow with Java-style arrays and threads. Concurrency is captured in a generic framework semantics for adding concurrency through interleaving to a sequential semantics, which features dynamic thread creation, inter-thread communication via shared memory, lock synchronisation and joins. Also, threads can suspend themselves and be notified by others. We instantiate the framework with the adapted versions of both Jinja source and byte code and show type safety for the multithreaded case. Equally, the compiler from source to byte code is extended, for which we prove weak bisimilarity between the source code small step semantics and the defensive Jinja virtual machine. On top of this, we formalise the JMM and show the DRF guarantee and consistency. For description of the different parts, see Lochbihler's papers at FOOL 2008, ESOP 2010, ITP 2011, and ESOP 2012. extra-history = Change history: [2008-04-23]: added bytecode formalisation with arrays and threads, added thread joins (revision f74a8be156a7)
[2009-04-27]: added verified compiler from source code to bytecode; encapsulate native methods in separate semantics (revision e4f26541e58a)
[2009-11-30]: extended compiler correctness proof to infinite and deadlocking computations (revision e50282397435)
[2010-06-08]: added thread interruption; new abstract memory model with sequential consistency as implementation (revision 0cb9e8dbd78d)
[2010-06-28]: new thread interruption model (revision c0440d0a1177)
[2010-10-15]: preliminary version of the Java memory model for source code (revision 02fee0ef3ca2)
[2010-12-16]: improved version of the Java memory model, also for bytecode executable scheduler for source code semantics (revision 1f41c1842f5a)
[2011-02-02]: simplified code generator setup new random scheduler (revision 3059dafd013f)
[2011-07-21]: new interruption model, generalized JMM proof of DRF guarantee, allow class Object to declare methods and fields, simplified subtyping relation, corrected division and modulo implementation (revision 46e4181ed142)
[2012-02-16]: added example programs (revision bf0b06c8913d)
[2012-11-21]: type safety proof for the Java memory model, allow spurious wake-ups (revision 76063d860ae0)
[2013-05-16]: support for non-deterministic memory allocators (revision cc3344a49ced)
[2017-10-20]: add an atomic compare-and-swap operation for volatile fields (revision a6189b1d6b30)
notify = mail@andreas-lochbihler.de [Locally-Nameless-Sigma] title = Locally Nameless Sigma Calculus author = Ludovic Henrio , Florian Kammüller , Bianca Lutz , Henry Sudhof date = 2010-04-30 topic = Computer science/Programming languages/Language definitions abstract = We present a Theory of Objects based on the original functional sigma-calculus by Abadi and Cardelli but with an additional parameter to methods. We prove confluence of the operational semantics following the outline of Nipkow's proof of confluence for the lambda-calculus reusing his theory Commutation, a generic diamond lemma reduction. We furthermore formalize a simple type system for our sigma-calculus including a proof of type safety. The entire development uses the concept of Locally Nameless representation for binders. We reuse an earlier proof of confluence for a simpler sigma-calculus based on de Bruijn indices and lists to represent objects. notify = nipkow@in.tum.de [Attack_Trees] title = Attack Trees in Isabelle for GDPR compliance of IoT healthcare systems author = Florian Kammueller topic = Computer science/Security date = 2020-04-27 notify = florian.kammuller@gmail.com abstract = In this article, we present a proof theory for Attack Trees. Attack Trees are a well established and useful model for the construction of attacks on systems since they allow a stepwise exploration of high level attacks in application scenarios. Using the expressiveness of Higher Order Logic in Isabelle, we develop a generic theory of Attack Trees with a state-based semantics based on Kripke structures and CTL. The resulting framework allows mechanically supported logic analysis of the meta-theory of the proof calculus of Attack Trees and at the same time the developed proof theory enables application to case studies. A central correctness and completeness result proved in Isabelle establishes a connection between the notion of Attack Tree validity and CTL. The application is illustrated on the example of a healthcare IoT system and GDPR compliance verification. [AutoFocus-Stream] title = AutoFocus Stream Processing for Single-Clocking and Multi-Clocking Semantics author = David Trachtenherz <> date = 2011-02-23 topic = Computer science/Programming languages/Language definitions abstract = We formalize the AutoFocus Semantics (a time-synchronous subset of the Focus formalism) as stream processing functions on finite and infinite message streams represented as finite/infinite lists. The formalization comprises both the conventional single-clocking semantics (uniform global clock for all components and communications channels) and its extension to multi-clocking semantics (internal execution clocking of a component may be a multiple of the external communication clocking). The semantics is defined by generic stream processing functions making it suitable for simulation/code generation in Isabelle/HOL. Furthermore, a number of AutoFocus semantics properties are formalized using definitions from the IntervalLogic theories. notify = nipkow@in.tum.de [FocusStreamsCaseStudies] title = Stream Processing Components: Isabelle/HOL Formalisation and Case Studies author = Maria Spichkova date = 2013-11-14 topic = Computer science/Programming languages/Language definitions abstract = This set of theories presents an Isabelle/HOL formalisation of stream processing components introduced in Focus, a framework for formal specification and development of interactive systems. This is an extended and updated version of the formalisation, which was elaborated within the methodology "Focus on Isabelle". In addition, we also applied the formalisation on three case studies that cover different application areas: process control (Steam Boiler System), data transmission (FlexRay communication protocol), memory and processing components (Automotive-Gateway System). notify = lp15@cam.ac.uk, maria.spichkova@rmit.edu.au [Isabelle_Meta_Model] title = A Meta-Model for the Isabelle API author = Frédéric Tuong , Burkhart Wolff date = 2015-09-16 topic = Computer science/Programming languages/Language definitions abstract = We represent a theory of (a fragment of) Isabelle/HOL in Isabelle/HOL. The purpose of this exercise is to write packages for domain-specific specifications such as class models, B-machines, ..., and generally speaking, any domain-specific languages whose abstract syntax can be defined by a HOL "datatype". On this basis, the Isabelle code-generator can then be used to generate code for global context transformations as well as tactic code.

Consequently the package is geared towards parsing, printing and code-generation to the Isabelle API. It is at the moment not sufficiently rich for doing meta theory on Isabelle itself. Extensions in this direction are possible though.

Moreover, the chosen fragment is fairly rudimentary. However it should be easily adapted to one's needs if a package is written on top of it. The supported API contains types, terms, transformation of global context like definitions and data-type declarations as well as infrastructure for Isar-setups.

This theory is drawn from the Featherweight OCL project where it is used to construct a package for object-oriented data-type theories generated from UML class diagrams. The Featherweight OCL, for example, allows for both the direct execution of compiled tactic code by the Isabelle API as well as the generation of ".thy"-files for debugging purposes.

Gained experience from this project shows that the compiled code is sufficiently efficient for practical purposes while being based on a formal model on which properties of the package can be proven such as termination of certain transformations, correctness, etc. notify = tuong@users.gforge.inria.fr, wolff@lri.fr [Clean] title = Clean - An Abstract Imperative Programming Language and its Theory author = Frédéric Tuong , Burkhart Wolff topic = Computer science/Programming languages, Computer science/Semantics date = 2019-10-04 notify = wolff@lri.fr, ftuong@lri.fr abstract = Clean is based on a simple, abstract execution model for an imperative target language. “Abstract” is understood in contrast to “Concrete Semantics”; alternatively, the term “shallow-style embedding” could be used. It strives for a type-safe notion of program-variables, an incremental construction of the typed state-space, support of incremental verification, and open-world extensibility of new type definitions being intertwined with the program definitions. Clean is based on a “no-frills” state-exception monad with the usual definitions of bind and unit for the compositional glue of state-based computations. Clean offers conditionals and loops supporting C-like control-flow operators such as break and return. The state-space construction is based on the extensible record package. Direct recursion of procedures is supported. Clean’s design strives for extreme simplicity. It is geared towards symbolic execution and proven correct verification tools. The underlying libraries of this package, however, deliberately restrict themselves to the most elementary infrastructure for these tasks. The package is intended to serve as demonstrator semantic backend for Isabelle/C, or for the test-generation techniques. [PCF] title = Logical Relations for PCF author = Peter Gammie date = 2012-07-01 topic = Computer science/Programming languages/Lambda calculi abstract = We apply Andy Pitts's methods of defining relations over domains to several classical results in the literature. We show that the Y combinator coincides with the domain-theoretic fixpoint operator, that parallel-or and the Plotkin existential are not definable in PCF, that the continuation semantics for PCF coincides with the direct semantics, and that our domain-theoretic semantics for PCF is adequate for reasoning about contextual equivalence in an operational semantics. Our version of PCF is untyped and has both strict and non-strict function abstractions. The development is carried out in HOLCF. notify = peteg42@gmail.com [POPLmark-deBruijn] title = POPLmark Challenge Via de Bruijn Indices author = Stefan Berghofer date = 2007-08-02 topic = Computer science/Programming languages/Lambda calculi abstract = We present a solution to the POPLmark challenge designed by Aydemir et al., which has as a goal the formalization of the meta-theory of System F<:. The formalization is carried out in the theorem prover Isabelle/HOL using an encoding based on de Bruijn indices. We start with a relatively simple formalization covering only the basic features of System F<:, and explain how it can be extended to also cover records and more advanced binding constructs. notify = berghofe@in.tum.de [Lam-ml-Normalization] title = Strong Normalization of Moggis's Computational Metalanguage author = Christian Doczkal date = 2010-08-29 topic = Computer science/Programming languages/Lambda calculi abstract = Handling variable binding is one of the main difficulties in formal proofs. In this context, Moggi's computational metalanguage serves as an interesting case study. It features monadic types and a commuting conversion rule that rearranges the binding structure. Lindley and Stark have given an elegant proof of strong normalization for this calculus. The key construction in their proof is a notion of relational TT-lifting, using stacks of elimination contexts to obtain a Girard-Tait style logical relation. I give a formalization of their proof in Isabelle/HOL-Nominal with a particular emphasis on the treatment of bound variables. notify = doczkal@ps.uni-saarland.de, nipkow@in.tum.de [MiniML] title = Mini ML author = Wolfgang Naraschewski <>, Tobias Nipkow date = 2004-03-19 topic = Computer science/Programming languages/Type systems abstract = This theory defines the type inference rules and the type inference algorithm W for MiniML (simply-typed lambda terms with let) due to Milner. It proves the soundness and completeness of W w.r.t. the rules. notify = kleing@cse.unsw.edu.au [Simpl] title = A Sequential Imperative Programming Language Syntax, Semantics, Hoare Logics and Verification Environment author = Norbert Schirmer <> date = 2008-02-29 topic = Computer science/Programming languages/Language definitions, Computer science/Programming languages/Logics license = LGPL abstract = We present the theory of Simpl, a sequential imperative programming language. We introduce its syntax, its semantics (big and small-step operational semantics) and Hoare logics for both partial as well as total correctness. We prove soundness and completeness of the Hoare logic. We integrate and automate the Hoare logic in Isabelle/HOL to obtain a practically usable verification environment for imperative programs. Simpl is independent of a concrete programming language but expressive enough to cover all common language features: mutually recursive procedures, abrupt termination and exceptions, runtime faults, local and global variables, pointers and heap, expressions with side effects, pointers to procedures, partial application and closures, dynamic method invocation and also unbounded nondeterminism. notify = kleing@cse.unsw.edu.au, norbert.schirmer@web.de [Separation_Algebra] title = Separation Algebra author = Gerwin Klein , Rafal Kolanski , Andrew Boyton date = 2012-05-11 topic = Computer science/Programming languages/Logics license = BSD abstract = We present a generic type class implementation of separation algebra for Isabelle/HOL as well as lemmas and generic tactics which can be used directly for any instantiation of the type class.

The ex directory contains example instantiations that include structures such as a heap or virtual memory.

The abstract separation algebra is based upon "Abstract Separation Logic" by Calcagno et al. These theories are also the basis of the ITP 2012 rough diamond "Mechanised Separation Algebra" by the authors.

The aim of this work is to support and significantly reduce the effort for future separation logic developments in Isabelle/HOL by factoring out the part of separation logic that can be treated abstractly once and for all. This includes developing typical default rule sets for reasoning as well as automated tactic support for separation logic. notify = kleing@cse.unsw.edu.au, rafal.kolanski@nicta.com.au [Separation_Logic_Imperative_HOL] title = A Separation Logic Framework for Imperative HOL author = Peter Lammich , Rene Meis date = 2012-11-14 topic = Computer science/Programming languages/Logics license = BSD abstract = We provide a framework for separation-logic based correctness proofs of Imperative HOL programs. Our framework comes with a set of proof methods to automate canonical tasks such as verification condition generation and frame inference. Moreover, we provide a set of examples that show the applicability of our framework. The examples include algorithms on lists, hash-tables, and union-find trees. We also provide abstract interfaces for lists, maps, and sets, that allow to develop generic imperative algorithms and use data-refinement techniques.
As we target Imperative HOL, our programs can be translated to efficiently executable code in various target languages, including ML, OCaml, Haskell, and Scala. notify = lammich@in.tum.de [Inductive_Confidentiality] title = Inductive Study of Confidentiality author = Giampaolo Bella date = 2012-05-02 topic = Computer science/Security abstract = This document contains the full theory files accompanying article Inductive Study of Confidentiality --- for Everyone in Formal Aspects of Computing. They aim at an illustrative and didactic presentation of the Inductive Method of protocol analysis, focusing on the treatment of one of the main goals of security protocols: confidentiality against a threat model. The treatment of confidentiality, which in fact forms a key aspect of all protocol analysis tools, has been found cryptic by many learners of the Inductive Method, hence the motivation for this work. The theory files in this document guide the reader step by step towards design and proof of significant confidentiality theorems. These are developed against two threat models, the standard Dolev-Yao and a more audacious one, the General Attacker, which turns out to be particularly useful also for teaching purposes. notify = giamp@dmi.unict.it [Possibilistic_Noninterference] title = Possibilistic Noninterference author = Andrei Popescu , Johannes Hölzl date = 2012-09-10 topic = Computer science/Security, Computer science/Programming languages/Type systems abstract = We formalize a wide variety of Volpano/Smith-style noninterference notions for a while language with parallel composition. We systematize and classify these notions according to compositionality w.r.t. the language constructs. Compositionality yields sound syntactic criteria (a.k.a. type systems) in a uniform way.

An article about these proofs is published in the proceedings of the conference Certified Programs and Proofs 2012. notify = hoelzl@in.tum.de [SIFUM_Type_Systems] title = A Formalization of Assumptions and Guarantees for Compositional Noninterference author = Sylvia Grewe , Heiko Mantel , Daniel Schoepe date = 2014-04-23 topic = Computer science/Security, Computer science/Programming languages/Type systems abstract = Research in information-flow security aims at developing methods to identify undesired information leaks within programs from private (high) sources to public (low) sinks. For a concurrent system, it is desirable to have compositional analysis methods that allow for analyzing each thread independently and that nevertheless guarantee that the parallel composition of successfully analyzed threads satisfies a global security guarantee. However, such a compositional analysis should not be overly pessimistic about what an environment might do with shared resources. Otherwise, the analysis will reject many intuitively secure programs.

The paper "Assumptions and Guarantees for Compositional Noninterference" by Mantel et. al. presents one solution for this problem: an approach for compositionally reasoning about non-interference in concurrent programs via rely-guarantee-style reasoning. We present an Isabelle/HOL formalization of the concepts and proofs of this approach. notify = grewe@cs.tu-darmstadt.de [Dependent_SIFUM_Type_Systems] title = A Dependent Security Type System for Concurrent Imperative Programs author = Toby Murray , Robert Sison<>, Edward Pierzchalski<>, Christine Rizkallah notify = toby.murray@unimelb.edu.au date = 2016-06-25 topic = Computer science/Security, Computer science/Programming languages/Type systems abstract = The paper "Compositional Verification and Refinement of Concurrent Value-Dependent Noninterference" by Murray et. al. (CSF 2016) presents a dependent security type system for compositionally verifying a value-dependent noninterference property, defined in (Murray, PLAS 2015), for concurrent programs. This development formalises that security definition, the type system and its soundness proof, and demonstrates its application on some small examples. It was derived from the SIFUM_Type_Systems AFP entry, by Sylvia Grewe, Heiko Mantel and Daniel Schoepe, and whose structure it inherits. extra-history = Change history: [2016-08-19]: Removed unused "stop" parameter and "stop_no_eval" assumption from the sifum_security locale. (revision dbc482d36372) [2016-09-27]: Added security locale support for the imposition of requirements on the initial memory. (revision cce4ceb74ddb) [Dependent_SIFUM_Refinement] title = Compositional Security-Preserving Refinement for Concurrent Imperative Programs author = Toby Murray , Robert Sison<>, Edward Pierzchalski<>, Christine Rizkallah notify = toby.murray@unimelb.edu.au date = 2016-06-28 topic = Computer science/Security abstract = The paper "Compositional Verification and Refinement of Concurrent Value-Dependent Noninterference" by Murray et. al. (CSF 2016) presents a compositional theory of refinement for a value-dependent noninterference property, defined in (Murray, PLAS 2015), for concurrent programs. This development formalises that refinement theory, and demonstrates its application on some small examples. extra-history = Change history: [2016-08-19]: Removed unused "stop" parameters from the sifum_refinement locale. (revision dbc482d36372) [2016-09-02]: TobyM extended "simple" refinement theory to be usable for all bisimulations. (revision 547f31c25f60) [Relational-Incorrectness-Logic] title = An Under-Approximate Relational Logic author = Toby Murray topic = Computer science/Programming languages/Logics, Computer science/Security date = 2020-03-12 notify = toby.murray@unimelb.edu.au abstract = Recently, authors have proposed under-approximate logics for reasoning about programs. So far, all such logics have been confined to reasoning about individual program behaviours. Yet there exist many over-approximate relational logics for reasoning about pairs of programs and relating their behaviours. We present the first under-approximate relational logic, for the simple imperative language IMP. We prove our logic is both sound and complete. Additionally, we show how reasoning in this logic can be decomposed into non-relational reasoning in an under-approximate Hoare logic, mirroring Beringer’s result for over-approximate relational logics. We illustrate the application of our logic on some small examples in which we provably demonstrate the presence of insecurity. [Strong_Security] title = A Formalization of Strong Security author = Sylvia Grewe , Alexander Lux , Heiko Mantel , Jens Sauer date = 2014-04-23 topic = Computer science/Security, Computer science/Programming languages/Type systems abstract = Research in information-flow security aims at developing methods to identify undesired information leaks within programs from private sources to public sinks. Noninterference captures this intuition. Strong security from Sabelfeld and Sands formalizes noninterference for concurrent systems.

We present an Isabelle/HOL formalization of strong security for arbitrary security lattices (Sabelfeld and Sands use a two-element security lattice in the original publication). The formalization includes compositionality proofs for strong security and a soundness proof for a security type system that checks strong security for programs in a simple while language with dynamic thread creation.

Our formalization of the security type system is abstract in the language for expressions and in the semantic side conditions for expressions. It can easily be instantiated with different syntactic approximations for these side conditions. The soundness proof of such an instantiation boils down to showing that these syntactic approximations imply the semantic side conditions. notify = grewe@cs.tu-darmstadt.de [WHATandWHERE_Security] title = A Formalization of Declassification with WHAT-and-WHERE-Security author = Sylvia Grewe , Alexander Lux , Heiko Mantel , Jens Sauer date = 2014-04-23 topic = Computer science/Security, Computer science/Programming languages/Type systems abstract = Research in information-flow security aims at developing methods to identify undesired information leaks within programs from private sources to public sinks. Noninterference captures this intuition by requiring that no information whatsoever flows from private sources to public sinks. However, in practice this definition is often too strict: Depending on the intuitive desired security policy, the controlled declassification of certain private information (WHAT) at certain points in the program (WHERE) might not result in an undesired information leak.

We present an Isabelle/HOL formalization of such a security property for controlled declassification, namely WHAT&WHERE-security from "Scheduler-Independent Declassification" by Lux, Mantel, and Perner. The formalization includes compositionality proofs for and a soundness proof for a security type system that checks for programs in a simple while language with dynamic thread creation.

Our formalization of the security type system is abstract in the language for expressions and in the semantic side conditions for expressions. It can easily be instantiated with different syntactic approximations for these side conditions. The soundness proof of such an instantiation boils down to showing that these syntactic approximations imply the semantic side conditions.

This Isabelle/HOL formalization uses theories from the entry Strong Security. notify = grewe@cs.tu-darmstadt.de [VolpanoSmith] title = A Correctness Proof for the Volpano/Smith Security Typing System author = Gregor Snelting , Daniel Wasserrab date = 2008-09-02 topic = Computer science/Programming languages/Type systems, Computer science/Security abstract = The Volpano/Smith/Irvine security type systems requires that variables are annotated as high (secret) or low (public), and provides typing rules which guarantee that secret values cannot leak to public output ports. This property of a program is called confidentiality. For a simple while-language without threads, our proof shows that typeability in the Volpano/Smith system guarantees noninterference. Noninterference means that if two initial states for program execution are low-equivalent, then the final states are low-equivalent as well. This indeed implies that secret values cannot leak to public ports. The proof defines an abstract syntax and operational semantics for programs, formalizes noninterference, and then proceeds by rule induction on the operational semantics. The mathematically most intricate part is the treatment of implicit flows. Note that the Volpano/Smith system is not flow-sensitive and thus quite unprecise, resulting in false alarms. However, due to the correctness property, all potential breaks of confidentiality are discovered. notify = [Abstract-Hoare-Logics] title = Abstract Hoare Logics author = Tobias Nipkow date = 2006-08-08 topic = Computer science/Programming languages/Logics abstract = These therories describe Hoare logics for a number of imperative language constructs, from while-loops to mutually recursive procedures. Both partial and total correctness are treated. In particular a proof system for total correctness of recursive procedures in the presence of unbounded nondeterminism is presented. notify = nipkow@in.tum.de [Stone_Algebras] title = Stone Algebras author = Walter Guttmann notify = walter.guttmann@canterbury.ac.nz date = 2016-09-06 topic = Mathematics/Order abstract = A range of algebras between lattices and Boolean algebras generalise the notion of a complement. We develop a hierarchy of these pseudo-complemented algebras that includes Stone algebras. Independently of this theory we study filters based on partial orders. Both theories are combined to prove Chen and Grätzer's construction theorem for Stone algebras. The latter involves extensive reasoning about algebraic structures in addition to reasoning in algebraic structures. [Kleene_Algebra] title = Kleene Algebra author = Alasdair Armstrong <>, Georg Struth , Tjark Weber date = 2013-01-15 topic = Computer science/Programming languages/Logics, Computer science/Automata and formal languages, Mathematics/Algebra abstract = These files contain a formalisation of variants of Kleene algebras and their most important models as axiomatic type classes in Isabelle/HOL. Kleene algebras are foundational structures in computing with applications ranging from automata and language theory to computational modeling, program construction and verification.

We start with formalising dioids, which are additively idempotent semirings, and expand them by axiomatisations of the Kleene star for finite iteration and an omega operation for infinite iteration. We show that powersets over a given monoid, (regular) languages, sets of paths in a graph, sets of computation traces, binary relations and formal power series form Kleene algebras, and consider further models based on lattices, max-plus semirings and min-plus semirings. We also demonstrate that dioids are closed under the formation of matrices (proofs for Kleene algebras remain to be completed).

On the one hand we have aimed at a reference formalisation of variants of Kleene algebras that covers a wide range of variants and the core theorems in a structured and modular way and provides readable proofs at text book level. On the other hand, we intend to use this algebraic hierarchy and its models as a generic algebraic middle-layer from which programming applications can quickly be explored, implemented and verified. notify = g.struth@sheffield.ac.uk, tjark.weber@it.uu.se [KAT_and_DRA] title = Kleene Algebra with Tests and Demonic Refinement Algebras author = Alasdair Armstrong <>, Victor B. F. Gomes , Georg Struth date = 2014-01-23 topic = Computer science/Programming languages/Logics, Computer science/Automata and formal languages, Mathematics/Algebra abstract = We formalise Kleene algebra with tests (KAT) and demonic refinement algebra (DRA) in Isabelle/HOL. KAT is relevant for program verification and correctness proofs in the partial correctness setting. While DRA targets similar applications in the context of total correctness. Our formalisation contains the two most important models of these algebras: binary relations in the case of KAT and predicate transformers in the case of DRA. In addition, we derive the inference rules for Hoare logic in KAT and its relational model and present a simple formally verified program verification tool prototype based on the algebraic approach. notify = g.struth@dcs.shef.ac.uk [KAD] title = Kleene Algebras with Domain author = Victor B. F. Gomes , Walter Guttmann , Peter Höfner , Georg Struth , Tjark Weber date = 2016-04-12 topic = Computer science/Programming languages/Logics, Computer science/Automata and formal languages, Mathematics/Algebra abstract = Kleene algebras with domain are Kleene algebras endowed with an operation that maps each element of the algebra to its domain of definition (or its complement) in abstract fashion. They form a simple algebraic basis for Hoare logics, dynamic logics or predicate transformer semantics. We formalise a modular hierarchy of algebras with domain and antidomain (domain complement) operations in Isabelle/HOL that ranges from domain and antidomain semigroups to modal Kleene algebras and divergence Kleene algebras. We link these algebras with models of binary relations and program traces. We include some examples from modal logics, termination and program analysis. notify = walter.guttman@canterbury.ac.nz, g.struth@sheffield.ac.uk, tjark.weber@it.uu.se [Regular_Algebras] title = Regular Algebras author = Simon Foster , Georg Struth date = 2014-05-21 topic = Computer science/Automata and formal languages, Mathematics/Algebra abstract = Regular algebras axiomatise the equational theory of regular expressions as induced by regular language identity. We use Isabelle/HOL for a detailed systematic study of regular algebras given by Boffa, Conway, Kozen and Salomaa. We investigate the relationships between these classes, formalise a soundness proof for the smallest class (Salomaa's) and obtain completeness of the largest one (Boffa's) relative to a deep result by Krob. In addition we provide a large collection of regular identities in the general setting of Boffa's axiom. Our regular algebra hierarchy is orthogonal to the Kleene algebra hierarchy in the Archive of Formal Proofs; we have not aimed at an integration for pragmatic reasons. notify = simon.foster@york.ac.uk, g.struth@sheffield.ac.uk [BytecodeLogicJmlTypes] title = A Bytecode Logic for JML and Types author = Lennart Beringer <>, Martin Hofmann date = 2008-12-12 topic = Computer science/Programming languages/Logics abstract = This document contains the Isabelle/HOL sources underlying the paper A bytecode logic for JML and types by Beringer and Hofmann, updated to Isabelle 2008. We present a program logic for a subset of sequential Java bytecode that is suitable for representing both, features found in high-level specification language JML as well as interpretations of high-level type systems. To this end, we introduce a fine-grained collection of assertions, including strong invariants, local annotations and VDM-reminiscent partial-correctness specifications. Thanks to a goal-oriented structure and interpretation of judgements, verification may proceed without recourse to an additional control flow analysis. The suitability for interpreting intensional type systems is illustrated by the proof-carrying-code style encoding of a type system for a first-order functional language which guarantees a constant upper bound on the number of objects allocated throughout an execution, be the execution terminating or non-terminating. Like the published paper, the formal development is restricted to a comparatively small subset of the JVML, lacking (among other features) exceptions, arrays, virtual methods, and static fields. This shortcoming has been overcome meanwhile, as our paper has formed the basis of the Mobius base logic, a program logic for the full sequential fragment of the JVML. Indeed, the present formalisation formed the basis of a subsequent formalisation of the Mobius base logic in the proof assistant Coq, which includes a proof of soundness with respect to the Bicolano operational semantics by Pichardie. notify = [DataRefinementIBP] title = Semantics and Data Refinement of Invariant Based Programs author = Viorel Preoteasa , Ralph-Johan Back date = 2010-05-28 topic = Computer science/Programming languages/Logics abstract = The invariant based programming is a technique of constructing correct programs by first identifying the basic situations (pre- and post-conditions and invariants) that can occur during the execution of the program, and then defining the transitions and proving that they preserve the invariants. Data refinement is a technique of building correct programs working on concrete datatypes as refinements of more abstract programs. In the theories presented here we formalize the predicate transformer semantics for invariant based programs and their data refinement. extra-history = Change history: [2012-01-05]: Moved some general complete lattice properties to the AFP entry Lattice Properties. Changed the definition of the data refinement relation to be more general and updated all corresponding theorems. Added new syntax for demonic and angelic update statements. notify = viorel.preoteasa@aalto.fi [RefinementReactive] title = Formalization of Refinement Calculus for Reactive Systems author = Viorel Preoteasa date = 2014-10-08 topic = Computer science/Programming languages/Logics abstract = We present a formalization of refinement calculus for reactive systems. Refinement calculus is based on monotonic predicate transformers (monotonic functions from sets of post-states to sets of pre-states), and it is a powerful formalism for reasoning about imperative programs. We model reactive systems as monotonic property transformers that transform sets of output infinite sequences into sets of input infinite sequences. Within this semantics we can model refinement of reactive systems, (unbounded) angelic and demonic nondeterminism, sequential composition, and other semantic properties. We can model systems that may fail for some inputs, and we can model compatibility of systems. We can specify systems that have liveness properties using linear temporal logic, and we can refine system specifications into systems based on symbolic transitions systems, suitable for implementations. notify = viorel.preoteasa@aalto.fi [SIFPL] title = Secure information flow and program logics author = Lennart Beringer <>, Martin Hofmann date = 2008-11-10 topic = Computer science/Programming languages/Logics, Computer science/Security abstract = We present interpretations of type systems for secure information flow in Hoare logic, complementing previous encodings in relational program logics. We first treat the imperative language IMP, extended by a simple procedure call mechanism. For this language we consider base-line non-interference in the style of Volpano et al. and the flow-sensitive type system by Hunt and Sands. In both cases, we show how typing derivations may be used to automatically generate proofs in the program logic that certify the absence of illicit flows. We then add instructions for object creation and manipulation, and derive appropriate proof rules for base-line non-interference. As a consequence of our work, standard verification technology may be used for verifying that a concrete program satisfies the non-interference property.

The present proof development represents an update of the formalisation underlying our paper [CSF 2007] and is intended to resolve any ambiguities that may be present in the paper. notify = lennart.beringer@ifi.lmu.de [TLA] title = A Definitional Encoding of TLA* in Isabelle/HOL author = Gudmund Grov , Stephan Merz date = 2011-11-19 topic = Computer science/Programming languages/Logics abstract = We mechanise the logic TLA* [Merz 1999], an extension of Lamport's Temporal Logic of Actions (TLA) [Lamport 1994] for specifying and reasoning about concurrent and reactive systems. Aiming at a framework for mechanising] the verification of TLA (or TLA*) specifications, this contribution reuses some elements from a previous axiomatic encoding of TLA in Isabelle/HOL by the second author [Merz 1998], which has been part of the Isabelle distribution. In contrast to that previous work, we give here a shallow, definitional embedding, with the following highlights:

  • a theory of infinite sequences, including a formalisation of the concepts of stuttering invariance central to TLA and TLA*;
  • a definition of the semantics of TLA*, which extends TLA by a mutually-recursive definition of formulas and pre-formulas, generalising TLA action formulas;
  • a substantial set of derived proof rules, including the TLA* axioms and Lamport's proof rules for system verification;
  • a set of examples illustrating the usage of Isabelle/TLA* for reasoning about systems.
Note that this work is unrelated to the ongoing development of a proof system for the specification language TLA+, which includes an encoding of TLA+ as a new Isabelle object logic [Chaudhuri et al 2010]. notify = ggrov@inf.ed.ac.uk [Compiling-Exceptions-Correctly] title = Compiling Exceptions Correctly author = Tobias Nipkow date = 2004-07-09 topic = Computer science/Programming languages/Compiling abstract = An exception compilation scheme that dynamically creates and removes exception handler entries on the stack. A formalization of an article of the same name by Hutton and Wright. notify = nipkow@in.tum.de [NormByEval] title = Normalization by Evaluation author = Klaus Aehlig , Tobias Nipkow date = 2008-02-18 topic = Computer science/Programming languages/Compiling abstract = This article formalizes normalization by evaluation as implemented in Isabelle. Lambda calculus plus term rewriting is compiled into a functional program with pattern matching. It is proved that the result of a successful evaluation is a) correct, i.e. equivalent to the input, and b) in normal form. notify = nipkow@in.tum.de [Program-Conflict-Analysis] title = Formalization of Conflict Analysis of Programs with Procedures, Thread Creation, and Monitors topic = Computer science/Programming languages/Static analysis author = Peter Lammich , Markus Müller-Olm date = 2007-12-14 abstract = In this work we formally verify the soundness and precision of a static program analysis that detects conflicts (e. g. data races) in programs with procedures, thread creation and monitors with the Isabelle theorem prover. As common in static program analysis, our program model abstracts guarded branching by nondeterministic branching, but completely interprets the call-/return behavior of procedures, synchronization by monitors, and thread creation. The analysis is based on the observation that all conflicts already occur in a class of particularly restricted schedules. These restricted schedules are suited to constraint-system-based program analysis. The formalization is based upon a flowgraph-based program model with an operational semantics as reference point. notify = peter.lammich@uni-muenster.de [Shivers-CFA] title = Shivers' Control Flow Analysis topic = Computer science/Programming languages/Static analysis author = Joachim Breitner date = 2010-11-16 abstract = In his dissertation, Olin Shivers introduces a concept of control flow graphs for functional languages, provides an algorithm to statically derive a safe approximation of the control flow graph and proves this algorithm correct. In this research project, Shivers' algorithms and proofs are formalized in the HOLCF extension of HOL. notify = mail@joachim-breitner.de, nipkow@in.tum.de [Slicing] title = Towards Certified Slicing author = Daniel Wasserrab date = 2008-09-16 topic = Computer science/Programming languages/Static analysis abstract = Slicing is a widely-used technique with applications in e.g. compiler technology and software security. Thus verification of algorithms in these areas is often based on the correctness of slicing, which should ideally be proven independent of concrete programming languages and with the help of well-known verifying techniques such as proof assistants. As a first step in this direction, this contribution presents a framework for dynamic and static intraprocedural slicing based on control flow and program dependence graphs. Abstracting from concrete syntax we base the framework on a graph representation of the program fulfilling certain structural and well-formedness properties.

The formalization consists of the basic framework (in subdirectory Basic/), the correctness proof for dynamic slicing (in subdirectory Dynamic/), the correctness proof for static intraprocedural slicing (in subdirectory StaticIntra/) and instantiations of the framework with a simple While language (in subdirectory While/) and the sophisticated object-oriented bytecode language of Jinja (in subdirectory JinjaVM/). For more information on the framework, see the TPHOLS 2008 paper by Wasserrab and Lochbihler and the PLAS 2009 paper by Wasserrab et al. notify = [HRB-Slicing] title = Backing up Slicing: Verifying the Interprocedural Two-Phase Horwitz-Reps-Binkley Slicer author = Daniel Wasserrab date = 2009-11-13 topic = Computer science/Programming languages/Static analysis abstract = After verifying dynamic and static interprocedural slicing, we present a modular framework for static interprocedural slicing. To this end, we formalized the standard two-phase slicer from Horwitz, Reps and Binkley (see their TOPLAS 12(1) 1990 paper) together with summary edges as presented by Reps et al. (see FSE 1994). The framework is again modular in the programming language by using an abstract CFG, defined via structural and well-formedness properties. Using a weak simulation between the original and sliced graph, we were able to prove the correctness of static interprocedural slicing. We also instantiate our framework with a simple While language with procedures. This shows that the chosen abstractions are indeed valid. notify = nipkow@in.tum.de [WorkerWrapper] title = The Worker/Wrapper Transformation author = Peter Gammie date = 2009-10-30 topic = Computer science/Programming languages/Transformations abstract = Gill and Hutton formalise the worker/wrapper transformation, building on the work of Launchbury and Peyton-Jones who developed it as a way of changing the type at which a recursive function operates. This development establishes the soundness of the technique and several examples of its use. notify = peteg42@gmail.com, nipkow@in.tum.de [JiveDataStoreModel] title = Jive Data and Store Model author = Nicole Rauch , Norbert Schirmer <> date = 2005-06-20 license = LGPL topic = Computer science/Programming languages/Misc abstract = This document presents the formalization of an object-oriented data and store model in Isabelle/HOL. This model is being used in the Java Interactive Verification Environment, Jive. notify = kleing@cse.unsw.edu.au, schirmer@in.tum.de [HotelKeyCards] title = Hotel Key Card System author = Tobias Nipkow date = 2006-09-09 topic = Computer science/Security abstract = Two models of an electronic hotel key card system are contrasted: a state based and a trace based one. Both are defined, verified, and proved equivalent in the theorem prover Isabelle/HOL. It is shown that if a guest follows a certain safety policy regarding her key cards, she can be sure that nobody but her can enter her room. notify = nipkow@in.tum.de [RSAPSS] title = SHA1, RSA, PSS and more author = Christina Lindenberg <>, Kai Wirt <> date = 2005-05-02 topic = Computer science/Security/Cryptography abstract = Formal verification is getting more and more important in computer science. However the state of the art formal verification methods in cryptography are very rudimentary. These theories are one step to provide a tool box allowing the use of formal methods in every aspect of cryptography. Moreover we present a proof of concept for the feasibility of verification techniques to a standard signature algorithm. notify = nipkow@in.tum.de [InformationFlowSlicing] title = Information Flow Noninterference via Slicing author = Daniel Wasserrab date = 2010-03-23 topic = Computer science/Security abstract =

In this contribution, we show how correctness proofs for intra- and interprocedural slicing can be used to prove that slicing is able to guarantee information flow noninterference. Moreover, we also illustrate how to lift the control flow graphs of the respective frameworks such that they fulfil the additional assumptions needed in the noninterference proofs. A detailed description of the intraprocedural proof and its interplay with the slicing framework can be found in the PLAS'09 paper by Wasserrab et al.

This entry contains the part for intra-procedural slicing. See entry InformationFlowSlicing_Inter for the inter-procedural part.

extra-history = Change history: [2016-06-10]: The original entry InformationFlowSlicing contained both the inter- and intra-procedural case was split into two for easier maintenance. notify = [InformationFlowSlicing_Inter] title = Inter-Procedural Information Flow Noninterference via Slicing author = Daniel Wasserrab date = 2010-03-23 topic = Computer science/Security abstract =

In this contribution, we show how correctness proofs for intra- and interprocedural slicing can be used to prove that slicing is able to guarantee information flow noninterference. Moreover, we also illustrate how to lift the control flow graphs of the respective frameworks such that they fulfil the additional assumptions needed in the noninterference proofs. A detailed description of the intraprocedural proof and its interplay with the slicing framework can be found in the PLAS'09 paper by Wasserrab et al.

This entry contains the part for inter-procedural slicing. See entry InformationFlowSlicing for the intra-procedural part.

extra-history = Change history: [2016-06-10]: The original entry InformationFlowSlicing contained both the inter- and intra-procedural case was split into two for easier maintenance. notify = [ComponentDependencies] title = Formalisation and Analysis of Component Dependencies author = Maria Spichkova date = 2014-04-28 topic = Computer science/System description languages abstract = This set of theories presents a formalisation in Isabelle/HOL of data dependencies between components. The approach allows to analyse system structure oriented towards efficient checking of system: it aims at elaborating for a concrete system, which parts of the system are necessary to check a given property. notify = maria.spichkova@rmit.edu.au [Verified-Prover] title = A Mechanically Verified, Efficient, Sound and Complete Theorem Prover For First Order Logic author = Tom Ridge <> date = 2004-09-28 topic = Logic/General logic/Mechanization of proofs abstract = Soundness and completeness for a system of first order logic are formally proved, building on James Margetson's formalization of work by Wainer and Wallen. The completeness proofs naturally suggest an algorithm to derive proofs. This algorithm, which can be implemented tail recursively, is formalized in Isabelle/HOL. The algorithm can be executed via the rewriting tactics of Isabelle. Alternatively, the definitions can be exported to OCaml, yielding a directly executable program. notify = lp15@cam.ac.uk [Completeness] title = Completeness theorem author = James Margetson <>, Tom Ridge <> date = 2004-09-20 topic = Logic/Proof theory abstract = The completeness of first-order logic is proved, following the first five pages of Wainer and Wallen's chapter of the book Proof Theory by Aczel et al., CUP, 1992. Their presentation of formulas allows the proofs to use symmetry arguments. Margetson formalized this theorem by early 2000. The Isar conversion is thanks to Tom Ridge. A paper describing the formalization is available [pdf]. notify = lp15@cam.ac.uk [Ordinal] title = Countable Ordinals author = Brian Huffman date = 2005-11-11 topic = Logic/Set theory abstract = This development defines a well-ordered type of countable ordinals. It includes notions of continuous and normal functions, recursively defined functions over ordinals, least fixed-points, and derivatives. Much of ordinal arithmetic is formalized, including exponentials and logarithms. The development concludes with formalizations of Cantor Normal Form and Veblen hierarchies over normal functions. notify = lcp@cl.cam.ac.uk [Ordinals_and_Cardinals] title = Ordinals and Cardinals author = Andrei Popescu <> date = 2009-09-01 topic = Logic/Set theory abstract = We develop a basic theory of ordinals and cardinals in Isabelle/HOL, up to the point where some cardinality facts relevant for the ``working mathematician" become available. Unlike in set theory, here we do not have at hand canonical notions of ordinal and cardinal. Therefore, here an ordinal is merely a well-order relation and a cardinal is an ordinal minim w.r.t. order embedding on its field. extra-history = Change history: [2012-09-25]: This entry has been discontinued because it is now part of the Isabelle distribution. notify = uuomul@yahoo.com, nipkow@in.tum.de [FOL-Fitting] title = First-Order Logic According to Fitting author = Stefan Berghofer contributors = Asta Halkjær From date = 2007-08-02 topic = Logic/General logic/Classical first-order logic abstract = We present a formalization of parts of Melvin Fitting's book "First-Order Logic and Automated Theorem Proving". The formalization covers the syntax of first-order logic, its semantics, the model existence theorem, a natural deduction proof calculus together with a proof of correctness and completeness, as well as the Löwenheim-Skolem theorem. extra-history = Change history: [2018-07-21]: Proved completeness theorem for open formulas. Proofs are now written in the declarative style. Enumeration of pairs and datatypes is automated using the Countable theory. notify = berghofe@in.tum.de [Epistemic_Logic] title = Epistemic Logic author = Asta Halkjær From topic = Logic/General logic/Logics of knowledge and belief date = 2018-10-29 notify = ahfrom@dtu.dk abstract = This work is a formalization of epistemic logic with countably many agents. It includes proofs of soundness and completeness for the axiom system K. The completeness proof is based on the textbook "Reasoning About Knowledge" by Fagin, Halpern, Moses and Vardi (MIT Press 1995). [SequentInvertibility] title = Invertibility in Sequent Calculi author = Peter Chapman <> date = 2009-08-28 topic = Logic/Proof theory license = LGPL abstract = The invertibility of the rules of a sequent calculus is important for guiding proof search and can be used in some formalised proofs of Cut admissibility. We present sufficient conditions for when a rule is invertible with respect to a calculus. We illustrate the conditions with examples. It must be noted we give purely syntactic criteria; no guarantees are given as to the suitability of the rules. notify = pc@cs.st-andrews.ac.uk, nipkow@in.tum.de [LinearQuantifierElim] title = Quantifier Elimination for Linear Arithmetic author = Tobias Nipkow date = 2008-01-11 topic = Logic/General logic/Decidability of theories abstract = This article formalizes quantifier elimination procedures for dense linear orders, linear real arithmetic and Presburger arithmetic. In each case both a DNF-based non-elementary algorithm and one or more (doubly) exponential NNF-based algorithms are formalized, including the well-known algorithms by Ferrante and Rackoff and by Cooper. The NNF-based algorithms for dense linear orders are new but based on Ferrante and Rackoff and on an algorithm by Loos and Weisspfenning which simulates infenitesimals. All algorithms are directly executable. In particular, they yield reflective quantifier elimination procedures for HOL itself. The formalization makes heavy use of locales and is therefore highly modular. notify = nipkow@in.tum.de [Nat-Interval-Logic] title = Interval Temporal Logic on Natural Numbers author = David Trachtenherz <> date = 2011-02-23 topic = Logic/General logic/Temporal logic abstract = We introduce a theory of temporal logic operators using sets of natural numbers as time domain, formalized in a shallow embedding manner. The theory comprises special natural intervals (theory IL_Interval: open and closed intervals, continuous and modulo intervals, interval traversing results), operators for shifting intervals to left/right on the number axis as well as expanding/contracting intervals by constant factors (theory IL_IntervalOperators.thy), and ultimately definitions and results for unary and binary temporal operators on arbitrary natural sets (theory IL_TemporalOperators). notify = nipkow@in.tum.de [Recursion-Theory-I] title = Recursion Theory I author = Michael Nedzelsky <> date = 2008-04-05 topic = Logic/Computability abstract = This document presents the formalization of introductory material from recursion theory --- definitions and basic properties of primitive recursive functions, Cantor pairing function and computably enumerable sets (including a proof of existence of a one-complete computably enumerable set and a proof of the Rice's theorem). notify = MichaelNedzelsky@yandex.ru [Free-Boolean-Algebra] topic = Logic/General logic/Classical propositional logic title = Free Boolean Algebra author = Brian Huffman date = 2010-03-29 abstract = This theory defines a type constructor representing the free Boolean algebra over a set of generators. Values of type (α)formula represent propositional formulas with uninterpreted variables from type α, ordered by implication. In addition to all the standard Boolean algebra operations, the library also provides a function for building homomorphisms to any other Boolean algebra type. notify = brianh@cs.pdx.edu [Sort_Encodings] title = Sound and Complete Sort Encodings for First-Order Logic author = Jasmin Christian Blanchette , Andrei Popescu date = 2013-06-27 topic = Logic/General logic/Mechanization of proofs abstract = This is a formalization of the soundness and completeness properties for various efficient encodings of sorts in unsorted first-order logic used by Isabelle's Sledgehammer tool.

Essentially, the encodings proceed as follows: a many-sorted problem is decorated with (as few as possible) tags or guards that make the problem monotonic; then sorts can be soundly erased.

The development employs a formalization of many-sorted first-order logic in clausal form (clauses, structures and the basic properties of the satisfaction relation), which could be of interest as the starting point for other formalizations of first-order logic metatheory. notify = uuomul@yahoo.com [Lambda_Free_RPOs] title = Formalization of Recursive Path Orders for Lambda-Free Higher-Order Terms author = Jasmin Christian Blanchette , Uwe Waldmann , Daniel Wand date = 2016-09-23 topic = Logic/Rewriting abstract = This Isabelle/HOL formalization defines recursive path orders (RPOs) for higher-order terms without lambda-abstraction and proves many useful properties about them. The main order fully coincides with the standard RPO on first-order terms also in the presence of currying, distinguishing it from previous work. An optimized variant is formalized as well. It appears promising as the basis of a higher-order superposition calculus. notify = jasmin.blanchette@gmail.com [Lambda_Free_KBOs] title = Formalization of Knuth–Bendix Orders for Lambda-Free Higher-Order Terms author = Heiko Becker , Jasmin Christian Blanchette , Uwe Waldmann , Daniel Wand date = 2016-11-12 topic = Logic/Rewriting abstract = This Isabelle/HOL formalization defines Knuth–Bendix orders for higher-order terms without lambda-abstraction and proves many useful properties about them. The main order fully coincides with the standard transfinite KBO with subterm coefficients on first-order terms. It appears promising as the basis of a higher-order superposition calculus. notify = jasmin.blanchette@gmail.com [Lambda_Free_EPO] title = Formalization of the Embedding Path Order for Lambda-Free Higher-Order Terms author = Alexander Bentkamp topic = Logic/Rewriting date = 2018-10-19 notify = a.bentkamp@vu.nl abstract = This Isabelle/HOL formalization defines the Embedding Path Order (EPO) for higher-order terms without lambda-abstraction and proves many useful properties about it. In contrast to the lambda-free recursive path orders, it does not fully coincide with RPO on first-order terms, but it is compatible with arbitrary higher-order contexts. [Nested_Multisets_Ordinals] title = Formalization of Nested Multisets, Hereditary Multisets, and Syntactic Ordinals author = Jasmin Christian Blanchette , Mathias Fleury , Dmitriy Traytel date = 2016-11-12 topic = Logic/Rewriting abstract = This Isabelle/HOL formalization introduces a nested multiset datatype and defines Dershowitz and Manna's nested multiset order. The order is proved well founded and linear. By removing one constructor, we transform the nested multisets into hereditary multisets. These are isomorphic to the syntactic ordinals—the ordinals can be recursively expressed in Cantor normal form. Addition, subtraction, multiplication, and linear orders are provided on this type. notify = jasmin.blanchette@gmail.com [Abstract-Rewriting] title = Abstract Rewriting topic = Logic/Rewriting date = 2010-06-14 author = Christian Sternagel , René Thiemann license = LGPL abstract = We present an Isabelle formalization of abstract rewriting (see, e.g., the book by Baader and Nipkow). First, we define standard relations like joinability, meetability, conversion, etc. Then, we formalize important properties of abstract rewrite systems, e.g., confluence and strong normalization. Our main concern is on strong normalization, since this formalization is the basis of CeTA (which is mainly about strong normalization of term rewrite systems). Hence lemmas involving strong normalization constitute by far the biggest part of this theory. One of those is Newman's lemma. extra-history = Change history: [2010-09-17]: Added theories defining several (ordered) semirings related to strong normalization and giving some standard instances.
[2013-10-16]: Generalized delta-orders from rationals to Archimedean fields. notify = christian.sternagel@uibk.ac.at, rene.thiemann@uibk.ac.at [First_Order_Terms] title = First-Order Terms author = Christian Sternagel , René Thiemann topic = Logic/Rewriting, Computer science/Algorithms license = LGPL date = 2018-02-06 notify = c.sternagel@gmail.com, rene.thiemann@uibk.ac.at abstract = We formalize basic results on first-order terms, including matching and a first-order unification algorithm, as well as well-foundedness of the subsumption order. This entry is part of the Isabelle Formalization of Rewriting IsaFoR, where first-order terms are omni-present: the unification algorithm is used to certify several confluence and termination techniques, like critical-pair computation and dependency graph approximations; and the subsumption order is a crucial ingredient for completion. [Free-Groups] title = Free Groups author = Joachim Breitner date = 2010-06-24 topic = Mathematics/Algebra abstract = Free Groups are, in a sense, the most generic kind of group. They are defined over a set of generators with no additional relations in between them. They play an important role in the definition of group presentations and in other fields. This theory provides the definition of Free Group as the set of fully canceled words in the generators. The universal property is proven, as well as some isomorphisms results about Free Groups. extra-history = Change history: [2011-12-11]: Added the Ping Pong Lemma. notify = [CofGroups] title = An Example of a Cofinitary Group in Isabelle/HOL author = Bart Kastermans date = 2009-08-04 topic = Mathematics/Algebra abstract = We formalize the usual proof that the group generated by the function k -> k + 1 on the integers gives rise to a cofinitary group. notify = nipkow@in.tum.de [Group-Ring-Module] title = Groups, Rings and Modules author = Hidetsune Kobayashi <>, L. Chen <>, H. Murao <> date = 2004-05-18 topic = Mathematics/Algebra abstract = The theory of groups, rings and modules is developed to a great depth. Group theory results include Zassenhaus's theorem and the Jordan-Hoelder theorem. The ring theory development includes ideals, quotient rings and the Chinese remainder theorem. The module development includes the Nakayama lemma, exact sequences and Tensor products. notify = lp15@cam.ac.uk [Robbins-Conjecture] title = A Complete Proof of the Robbins Conjecture author = Matthew Wampler-Doty <> date = 2010-05-22 topic = Mathematics/Algebra abstract = This document gives a formalization of the proof of the Robbins conjecture, following A. Mann, A Complete Proof of the Robbins Conjecture, 2003. notify = nipkow@in.tum.de [Valuation] title = Fundamental Properties of Valuation Theory and Hensel's Lemma author = Hidetsune Kobayashi <> date = 2007-08-08 topic = Mathematics/Algebra abstract = Convergence with respect to a valuation is discussed as convergence of a Cauchy sequence. Cauchy sequences of polynomials are defined. They are used to formalize Hensel's lemma. notify = lp15@cam.ac.uk [Rank_Nullity_Theorem] title = Rank-Nullity Theorem in Linear Algebra author = Jose Divasón , Jesús Aransay topic = Mathematics/Algebra date = 2013-01-16 abstract = In this contribution, we present some formalizations based on the HOL-Multivariate-Analysis session of Isabelle. Firstly, a generalization of several theorems of such library are presented. Secondly, some definitions and proofs involving Linear Algebra and the four fundamental subspaces of a matrix are shown. Finally, we present a proof of the result known in Linear Algebra as the ``Rank-Nullity Theorem'', which states that, given any linear map f from a finite dimensional vector space V to a vector space W, then the dimension of V is equal to the dimension of the kernel of f (which is a subspace of V) and the dimension of the range of f (which is a subspace of W). The proof presented here is based on the one given by Sheldon Axler in his book Linear Algebra Done Right. As a corollary of the previous theorem, and taking advantage of the relationship between linear maps and matrices, we prove that, for every matrix A (which has associated a linear map between finite dimensional vector spaces), the sum of its null space and its column space (which is equal to the range of the linear map) is equal to the number of columns of A. extra-history = Change history: [2014-07-14]: Added some generalizations that allow us to formalize the Rank-Nullity Theorem over finite dimensional vector spaces, instead of over the more particular euclidean spaces. Updated abstract. notify = jose.divasonm@unirioja.es, jesus-maria.aransay@unirioja.es [Affine_Arithmetic] title = Affine Arithmetic author = Fabian Immler date = 2014-02-07 topic = Mathematics/Analysis abstract = We give a formalization of affine forms as abstract representations of zonotopes. We provide affine operations as well as overapproximations of some non-affine operations like multiplication and division. Expressions involving those operations can automatically be turned into (executable) functions approximating the original expression in affine arithmetic. extra-history = Change history: [2015-01-31]: added algorithm for zonotope/hyperplane intersection
[2017-09-20]: linear approximations for all symbols from the floatarith data type notify = immler@in.tum.de [Laplace_Transform] title = Laplace Transform author = Fabian Immler topic = Mathematics/Analysis date = 2019-08-14 notify = fimmler@cs.cmu.edu abstract = This entry formalizes the Laplace transform and concrete Laplace transforms for arithmetic functions, frequency shift, integration and (higher) differentiation in the time domain. It proves Lerch's lemma and uniqueness of the Laplace transform for continuous functions. In order to formalize the foundational assumptions, this entry contains a formalization of piecewise continuous functions and functions of exponential order. [Cauchy] title = Cauchy's Mean Theorem and the Cauchy-Schwarz Inequality author = Benjamin Porter <> date = 2006-03-14 topic = Mathematics/Analysis abstract = This document presents the mechanised proofs of two popular theorems attributed to Augustin Louis Cauchy - Cauchy's Mean Theorem and the Cauchy-Schwarz Inequality. notify = kleing@cse.unsw.edu.au [Integration] title = Integration theory and random variables author = Stefan Richter date = 2004-11-19 topic = Mathematics/Analysis abstract = Lebesgue-style integration plays a major role in advanced probability. We formalize concepts of elementary measure theory, real-valued random variables as Borel-measurable functions, and a stepwise inductive definition of the integral itself. All proofs are carried out in human readable style using the Isar language. extra-note = Note: This article is of historical interest only. Lebesgue-style integration and probability theory are now available as part of the Isabelle/HOL distribution (directory Probability). notify = richter@informatik.rwth-aachen.de, nipkow@in.tum.de, hoelzl@in.tum.de [Ordinary_Differential_Equations] title = Ordinary Differential Equations author = Fabian Immler , Johannes Hölzl topic = Mathematics/Analysis date = 2012-04-26 abstract =

Session Ordinary-Differential-Equations formalizes ordinary differential equations (ODEs) and initial value problems. This work comprises proofs for local and global existence of unique solutions (Picard-Lindelöf theorem). Moreover, it contains a formalization of the (continuous or even differentiable) dependency of the flow on initial conditions as the flow of ODEs.

Not in the generated document are the following sessions:

  • HOL-ODE-Numerics: Rigorous numerical algorithms for computing enclosures of solutions based on Runge-Kutta methods and affine arithmetic. Reachability analysis with splitting and reduction at hyperplanes.
  • HOL-ODE-Examples: Applications of the numerical algorithms to concrete systems of ODEs.
  • Lorenz_C0, Lorenz_C1: Verified algorithms for checking C1-information according to Tucker's proof, computation of C0-information.

extra-history = Change history: [2014-02-13]: added an implementation of the Euler method based on affine arithmetic
[2016-04-14]: added flow and variational equation
[2016-08-03]: numerical algorithms for reachability analysis (using second-order Runge-Kutta methods, splitting, and reduction) implemented using Lammich's framework for automatic refinement
[2017-09-20]: added Poincare map and propagation of variational equation in reachability analysis, verified algorithms for C1-information and computations for C0-information of the Lorenz attractor. notify = immler@in.tum.de, hoelzl@in.tum.de [Polynomials] title = Executable Multivariate Polynomials author = Christian Sternagel , René Thiemann , Alexander Maletzky , Fabian Immler , Florian Haftmann , Andreas Lochbihler , Alexander Bentkamp date = 2010-08-10 topic = Mathematics/Analysis, Mathematics/Algebra, Computer science/Algorithms/Mathematical license = LGPL abstract = We define multivariate polynomials over arbitrary (ordered) semirings in combination with (executable) operations like addition, multiplication, and substitution. We also define (weak) monotonicity of polynomials and comparison of polynomials where we provide standard estimations like absolute positiveness or the more recent approach of Neurauter, Zankl, and Middeldorp. Moreover, it is proven that strongly normalizing (monotone) orders can be lifted to strongly normalizing (monotone) orders over polynomials. Our formalization was performed as part of the IsaFoR/CeTA-system which contains several termination techniques. The provided theories have been essential to formalize polynomial interpretations.

This formalization also contains an abstract representation as coefficient functions with finite support and a type of power-products. If this type is ordered by a linear (term) ordering, various additional notions, such as leading power-product, leading coefficient etc., are introduced as well. Furthermore, a lot of generic properties of, and functions on, multivariate polynomials are formalized, including the substitution and evaluation homomorphisms, embeddings of polynomial rings into larger rings (i.e. with one additional indeterminate), homogenization and dehomogenization of polynomials, and the canonical isomorphism between R[X,Y] and R[X][Y]. extra-history = Change history: [2010-09-17]: Moved theories on arbitrary (ordered) semirings to Abstract Rewriting.
[2016-10-28]: Added abstract representation of polynomials and authors Maletzky/Immler.
[2018-01-23]: Added authors Haftmann, Lochbihler after incorporating their formalization of multivariate polynomials based on Polynomial mappings. Moved material from Bentkamp's entry "Deep Learning".
[2019-04-18]: Added material about polynomials whose power-products are represented themselves by polynomial mappings. notify = rene.thiemann@uibk.ac.at, christian.sternagel@uibk.ac.at, alexander.maletzky@risc.jku.at, immler@in.tum.de [Sqrt_Babylonian] title = Computing N-th Roots using the Babylonian Method author = René Thiemann date = 2013-01-03 topic = Mathematics/Analysis license = LGPL abstract = We implement the Babylonian method to compute n-th roots of numbers. We provide precise algorithms for naturals, integers and rationals, and offer an approximation algorithm for square roots over linear ordered fields. Moreover, there are precise algorithms to compute the floor and the ceiling of n-th roots. extra-history = Change history: [2013-10-16]: Added algorithms to compute floor and ceiling of sqrt of integers. [2014-07-11]: Moved NthRoot_Impl from Real-Impl to this entry. notify = rene.thiemann@uibk.ac.at [Sturm_Sequences] title = Sturm's Theorem author = Manuel Eberl date = 2014-01-11 topic = Mathematics/Analysis abstract = Sturm's Theorem states that polynomial sequences with certain properties, so-called Sturm sequences, can be used to count the number of real roots of a real polynomial. This work contains a proof of Sturm's Theorem and code for constructing Sturm sequences efficiently. It also provides the “sturm” proof method, which can decide certain statements about the roots of real polynomials, such as “the polynomial P has exactly n roots in the interval I” or “P(x) > Q(x) for all x ∈ ℝ”. notify = eberlm@in.tum.de [Sturm_Tarski] title = The Sturm-Tarski Theorem author = Wenda Li date = 2014-09-19 topic = Mathematics/Analysis abstract = We have formalized the Sturm-Tarski theorem (also referred as the Tarski theorem), which generalizes Sturm's theorem. Sturm's theorem is usually used as a way to count distinct real roots, while the Sturm-Tarksi theorem forms the basis for Tarski's classic quantifier elimination for real closed field. notify = wl302@cam.ac.uk [Markov_Models] title = Markov Models author = Johannes Hölzl , Tobias Nipkow date = 2012-01-03 topic = Mathematics/Probability theory, Computer science/Automata and formal languages abstract = This is a formalization of Markov models in Isabelle/HOL. It builds on Isabelle's probability theory. The available models are currently Discrete-Time Markov Chains and a extensions of them with rewards.

As application of these models we formalize probabilistic model checking of pCTL formulas, analysis of IPv4 address allocation in ZeroConf and an analysis of the anonymity of the Crowds protocol. See here for the corresponding paper. notify = hoelzl@in.tum.de [Probabilistic_System_Zoo] title = A Zoo of Probabilistic Systems author = Johannes Hölzl , Andreas Lochbihler , Dmitriy Traytel date = 2015-05-27 topic = Computer science/Automata and formal languages abstract = Numerous models of probabilistic systems are studied in the literature. Coalgebra has been used to classify them into system types and compare their expressiveness. We formalize the resulting hierarchy of probabilistic system types by modeling the semantics of the different systems as codatatypes. This approach yields simple and concise proofs, as bisimilarity coincides with equality for codatatypes.

This work is described in detail in the ITP 2015 publication by the authors. notify = traytel@in.tum.de [Density_Compiler] title = A Verified Compiler for Probability Density Functions author = Manuel Eberl , Johannes Hölzl , Tobias Nipkow date = 2014-10-09 topic = Mathematics/Probability theory, Computer science/Programming languages/Compiling abstract = Bhat et al. [TACAS 2013] developed an inductive compiler that computes density functions for probability spaces described by programs in a probabilistic functional language. In this work, we implement such a compiler for a modified version of this language within the theorem prover Isabelle and give a formal proof of its soundness w.r.t. the semantics of the source and target language. Together with Isabelle's code generation for inductive predicates, this yields a fully verified, executable density compiler. The proof is done in two steps: First, an abstract compiler working with abstract functions modelled directly in the theorem prover's logic is defined and proved sound. Then, this compiler is refined to a concrete version that returns a target-language expression.

An article with the same title and authors is published in the proceedings of ESOP 2015. A detailed presentation of this work can be found in the first author's master's thesis. notify = hoelzl@in.tum.de [CAVA_Automata] title = The CAVA Automata Library author = Peter Lammich date = 2014-05-28 topic = Computer science/Automata and formal languages abstract = We report on the graph and automata library that is used in the fully verified LTL model checker CAVA. As most components of CAVA use some type of graphs or automata, a common automata library simplifies assembly of the components and reduces redundancy.

The CAVA Automata Library provides a hierarchy of graph and automata classes, together with some standard algorithms. Its object oriented design allows for sharing of algorithms, theorems, and implementations between its classes, and also simplifies extensions of the library. Moreover, it is integrated into the Automatic Refinement Framework, supporting automatic refinement of the abstract automata types to efficient data structures.

Note that the CAVA Automata Library is work in progress. Currently, it is very specifically tailored towards the requirements of the CAVA model checker. Nevertheless, the formalization techniques presented here allow an extension of the library to a wider scope. Moreover, they are not limited to graph libraries, but apply to class hierarchies in general.

The CAVA Automata Library is described in the paper: Peter Lammich, The CAVA Automata Library, Isabelle Workshop 2014. notify = lammich@in.tum.de [LTL] title = Linear Temporal Logic author = Salomon Sickert contributors = Benedikt Seidl date = 2016-03-01 topic = Logic/General logic/Temporal logic, Computer science/Automata and formal languages abstract = This theory provides a formalisation of linear temporal logic (LTL) and unifies previous formalisations within the AFP. This entry establishes syntax and semantics for this logic and decouples it from existing entries, yielding a common environment for theories reasoning about LTL. Furthermore a parser written in SML and an executable simplifier are provided. extra-history = Change history: [2019-03-12]: Support for additional operators, implementation of common equivalence relations, definition of syntactic fragments of LTL and the minimal disjunctive normal form.
notify = sickert@in.tum.de [LTL_to_GBA] title = Converting Linear-Time Temporal Logic to Generalized Büchi Automata author = Alexander Schimpf , Peter Lammich date = 2014-05-28 topic = Computer science/Automata and formal languages abstract = We formalize linear-time temporal logic (LTL) and the algorithm by Gerth et al. to convert LTL formulas to generalized Büchi automata. We also formalize some syntactic rewrite rules that can be applied to optimize the LTL formula before conversion. Moreover, we integrate the Stuttering Equivalence AFP-Entry by Stefan Merz, adapting the lemma that next-free LTL formula cannot distinguish between stuttering equivalent runs to our setting.

We use the Isabelle Refinement and Collection framework, as well as the Autoref tool, to obtain a refined version of our algorithm, from which efficiently executable code can be extracted. notify = lammich@in.tum.de [Gabow_SCC] title = Verified Efficient Implementation of Gabow's Strongly Connected Components Algorithm author = Peter Lammich date = 2014-05-28 topic = Computer science/Algorithms/Graph, Mathematics/Graph theory abstract = We present an Isabelle/HOL formalization of Gabow's algorithm for finding the strongly connected components of a directed graph. Using data refinement techniques, we extract efficient code that performs comparable to a reference implementation in Java. Our style of formalization allows for re-using large parts of the proofs when defining variants of the algorithm. We demonstrate this by verifying an algorithm for the emptiness check of generalized Büchi automata, re-using most of the existing proofs. notify = lammich@in.tum.de [Promela] title = Promela Formalization author = René Neumann date = 2014-05-28 topic = Computer science/System description languages abstract = We present an executable formalization of the language Promela, the description language for models of the model checker SPIN. This formalization is part of the work for a completely verified model checker (CAVA), but also serves as a useful (and executable!) description of the semantics of the language itself, something that is currently missing. The formalization uses three steps: It takes an abstract syntax tree generated from an SML parser, removes syntactic sugar and enriches it with type information. This further gets translated into a transition system, on which the semantic engine (read: successor function) operates. notify = [CAVA_LTL_Modelchecker] title = A Fully Verified Executable LTL Model Checker author = Javier Esparza , Peter Lammich , René Neumann , Tobias Nipkow , Alexander Schimpf , Jan-Georg Smaus date = 2014-05-28 topic = Computer science/Automata and formal languages abstract = We present an LTL model checker whose code has been completely verified using the Isabelle theorem prover. The checker consists of over 4000 lines of ML code. The code is produced using the Isabelle Refinement Framework, which allows us to split its correctness proof into (1) the proof of an abstract version of the checker, consisting of a few hundred lines of ``formalized pseudocode'', and (2) a verified refinement step in which mathematical sets and other abstract structures are replaced by implementations of efficient structures like red-black trees and functional arrays. This leads to a checker that, while still slower than unverified checkers, can already be used as a trusted reference implementation against which advanced implementations can be tested.

An early version of this model checker is described in the CAV 2013 paper with the same title. notify = lammich@in.tum.de [Fermat3_4] title = Fermat's Last Theorem for Exponents 3 and 4 and the Parametrisation of Pythagorean Triples author = Roelof Oosterhuis <> date = 2007-08-12 topic = Mathematics/Number theory abstract = This document presents the mechanised proofs of

  • Fermat's Last Theorem for exponents 3 and 4 and
  • the parametrisation of Pythagorean Triples.
notify = nipkow@in.tum.de, roelofoosterhuis@gmail.com [Perfect-Number-Thm] title = Perfect Number Theorem author = Mark Ijbema date = 2009-11-22 topic = Mathematics/Number theory abstract = These theories present the mechanised proof of the Perfect Number Theorem. notify = nipkow@in.tum.de [SumSquares] title = Sums of Two and Four Squares author = Roelof Oosterhuis <> date = 2007-08-12 topic = Mathematics/Number theory abstract = This document presents the mechanised proofs of the following results:
  • any prime number of the form 4m+1 can be written as the sum of two squares;
  • any natural number can be written as the sum of four squares
notify = nipkow@in.tum.de, roelofoosterhuis@gmail.com [Lehmer] title = Lehmer's Theorem author = Simon Wimmer , Lars Noschinski date = 2013-07-22 topic = Mathematics/Number theory abstract = In 1927, Lehmer presented criterions for primality, based on the converse of Fermat's litte theorem. This work formalizes the second criterion from Lehmer's paper, a necessary and sufficient condition for primality.

As a side product we formalize some properties of Euler's phi-function, the notion of the order of an element of a group, and the cyclicity of the multiplicative group of a finite field. notify = noschinl@gmail.com, simon.wimmer@tum.de [Pratt_Certificate] title = Pratt's Primality Certificates author = Simon Wimmer , Lars Noschinski date = 2013-07-22 topic = Mathematics/Number theory abstract = In 1975, Pratt introduced a proof system for certifying primes. He showed that a number p is prime iff a primality certificate for p exists. By showing a logarithmic upper bound on the length of the certificates in size of the prime number, he concluded that the decision problem for prime numbers is in NP. This work formalizes soundness and completeness of Pratt's proof system as well as an upper bound for the size of the certificate. notify = noschinl@gmail.com, simon.wimmer@tum.de [Monad_Memo_DP] title = Monadification, Memoization and Dynamic Programming author = Simon Wimmer , Shuwei Hu , Tobias Nipkow topic = Computer science/Programming languages/Transformations, Computer science/Algorithms, Computer science/Functional programming date = 2018-05-22 notify = wimmers@in.tum.de abstract = We present a lightweight framework for the automatic verified (functional or imperative) memoization of recursive functions. Our tool can turn a pure Isabelle/HOL function definition into a monadified version in a state monad or the Imperative HOL heap monad, and prove a correspondence theorem. We provide a variety of memory implementations for the two types of monads. A number of simple techniques allow us to achieve bottom-up computation and space-efficient memoization. The framework’s utility is demonstrated on a number of representative dynamic programming problems. A detailed description of our work can be found in the accompanying paper [2]. [Probabilistic_Timed_Automata] title = Probabilistic Timed Automata author = Simon Wimmer , Johannes Hölzl topic = Mathematics/Probability theory, Computer science/Automata and formal languages date = 2018-05-24 notify = wimmers@in.tum.de, hoelzl@in.tum.de abstract = We present a formalization of probabilistic timed automata (PTA) for which we try to follow the formula MDP + TA = PTA as far as possible: our work starts from our existing formalizations of Markov decision processes (MDP) and timed automata (TA) and combines them modularly. We prove the fundamental result for probabilistic timed automata: the region construction that is known from timed automata carries over to the probabilistic setting. In particular, this allows us to prove that minimum and maximum reachability probabilities can be computed via a reduction to MDP model checking, including the case where one wants to disregard unrealizable behavior. Further information can be found in our ITP paper [2]. [Hidden_Markov_Models] title = Hidden Markov Models author = Simon Wimmer topic = Mathematics/Probability theory, Computer science/Algorithms date = 2018-05-25 notify = wimmers@in.tum.de abstract = This entry contains a formalization of hidden Markov models [3] based on Johannes Hölzl's formalization of discrete time Markov chains [1]. The basic definitions are provided and the correctness of two main (dynamic programming) algorithms for hidden Markov models is proved: the forward algorithm for computing the likelihood of an observed sequence, and the Viterbi algorithm for decoding the most probable hidden state sequence. The Viterbi algorithm is made executable including memoization. Hidden markov models have various applications in natural language processing. For an introduction see Jurafsky and Martin [2]. [ArrowImpossibilityGS] title = Arrow and Gibbard-Satterthwaite author = Tobias Nipkow date = 2008-09-01 topic = Mathematics/Games and economics abstract = This article formalizes two proofs of Arrow's impossibility theorem due to Geanakoplos and derives the Gibbard-Satterthwaite theorem as a corollary. One formalization is based on utility functions, the other one on strict partial orders.

An article about these proofs is found here. notify = nipkow@in.tum.de [SenSocialChoice] title = Some classical results in Social Choice Theory author = Peter Gammie date = 2008-11-09 topic = Mathematics/Games and economics abstract = Drawing on Sen's landmark work "Collective Choice and Social Welfare" (1970), this development proves Arrow's General Possibility Theorem, Sen's Liberal Paradox and May's Theorem in a general setting. The goal was to make precise the classical statements and proofs of these results, and to provide a foundation for more recent results such as the Gibbard-Satterthwaite and Duggan-Schwartz theorems. notify = nipkow@in.tum.de [Vickrey_Clarke_Groves] title = VCG - Combinatorial Vickrey-Clarke-Groves Auctions author = Marco B. Caminati <>, Manfred Kerber , Christoph Lange, Colin Rowat date = 2015-04-30 topic = Mathematics/Games and economics abstract = A VCG auction (named after their inventors Vickrey, Clarke, and Groves) is a generalization of the single-good, second price Vickrey auction to the case of a combinatorial auction (multiple goods, from which any participant can bid on each possible combination). We formalize in this entry VCG auctions, including tie-breaking and prove that the functions for the allocation and the price determination are well-defined. Furthermore we show that the allocation function allocates goods only to participants, only goods in the auction are allocated, and no good is allocated twice. We also show that the price function is non-negative. These properties also hold for the automatically extracted Scala code. notify = mnfrd.krbr@gmail.com [Topology] title = Topology author = Stefan Friedrich <> date = 2004-04-26 topic = Mathematics/Topology abstract = This entry contains two theories. The first, Topology, develops the basic notions of general topology. The second, which can be viewed as a demonstration of the first, is called LList_Topology. It develops the topology of lazy lists. notify = lcp@cl.cam.ac.uk [Knot_Theory] title = Knot Theory author = T.V.H. Prathamesh date = 2016-01-20 topic = Mathematics/Topology abstract = This work contains a formalization of some topics in knot theory. The concepts that were formalized include definitions of tangles, links, framed links and link/tangle equivalence. The formalization is based on a formulation of links in terms of tangles. We further construct and prove the invariance of the Bracket polynomial. Bracket polynomial is an invariant of framed links closely linked to the Jones polynomial. This is perhaps the first attempt to formalize any aspect of knot theory in an interactive proof assistant. notify = prathamesh@imsc.res.in [Graph_Theory] title = Graph Theory author = Lars Noschinski date = 2013-04-28 topic = Mathematics/Graph theory abstract = This development provides a formalization of directed graphs, supporting (labelled) multi-edges and infinite graphs. A polymorphic edge type allows edges to be treated as pairs of vertices, if multi-edges are not required. Formalized properties are i.a. walks (and related concepts), connectedness and subgraphs and basic properties of isomorphisms.

This formalization is used to prove characterizations of Euler Trails, Shortest Paths and Kuratowski subgraphs. notify = noschinl@gmail.com [Planarity_Certificates] title = Planarity Certificates author = Lars Noschinski date = 2015-11-11 topic = Mathematics/Graph theory abstract = This development provides a formalization of planarity based on combinatorial maps and proves that Kuratowski's theorem implies combinatorial planarity. Moreover, it contains verified implementations of programs checking certificates for planarity (i.e., a combinatorial map) or non-planarity (i.e., a Kuratowski subgraph). notify = noschinl@gmail.com [Max-Card-Matching] title = Maximum Cardinality Matching author = Christine Rizkallah date = 2011-07-21 topic = Mathematics/Graph theory abstract =

A matching in a graph G is a subset M of the edges of G such that no two share an endpoint. A matching has maximum cardinality if its cardinality is at least as large as that of any other matching. An odd-set cover OSC of a graph G is a labeling of the nodes of G with integers such that every edge of G is either incident to a node labeled 1 or connects two nodes labeled with the same number i ≥ 2.

This article proves Edmonds theorem:
Let M be a matching in a graph G and let OSC be an odd-set cover of G. For any i ≥ 0, let n(i) be the number of nodes labeled i. If |M| = n(1) + ∑i ≥ 2(n(i) div 2), then M is a maximum cardinality matching.

notify = nipkow@in.tum.de [Girth_Chromatic] title = A Probabilistic Proof of the Girth-Chromatic Number Theorem author = Lars Noschinski date = 2012-02-06 topic = Mathematics/Graph theory abstract = This works presents a formalization of the Girth-Chromatic number theorem in graph theory, stating that graphs with arbitrarily large girth and chromatic number exist. The proof uses the theory of Random Graphs to prove the existence with probabilistic arguments. notify = noschinl@gmail.com [Random_Graph_Subgraph_Threshold] title = Properties of Random Graphs -- Subgraph Containment author = Lars Hupel date = 2014-02-13 topic = Mathematics/Graph theory, Mathematics/Probability theory abstract = Random graphs are graphs with a fixed number of vertices, where each edge is present with a fixed probability. We are interested in the probability that a random graph contains a certain pattern, for example a cycle or a clique. A very high edge probability gives rise to perhaps too many edges (which degrades performance for many algorithms), whereas a low edge probability might result in a disconnected graph. We prove a theorem about a threshold probability such that a higher edge probability will asymptotically almost surely produce a random graph with the desired subgraph. notify = hupel@in.tum.de [Flyspeck-Tame] title = Flyspeck I: Tame Graphs author = Gertrud Bauer <>, Tobias Nipkow date = 2006-05-22 topic = Mathematics/Graph theory abstract = These theories present the verified enumeration of tame plane graphs as defined by Thomas C. Hales in his proof of the Kepler Conjecture in his book Dense Sphere Packings. A Blueprint for Formal Proofs. [CUP 2012]. The values of the constants in the definition of tameness are identical to those in the Flyspeck project. The IJCAR 2006 paper by Nipkow, Bauer and Schultz refers to the original version of Hales' proof, the ITP 2011 paper by Nipkow refers to the Blueprint version of the proof. extra-history = Change history: [2010-11-02]: modified theories to reflect the modified definition of tameness in Hales' revised proof.
[2014-07-03]: modified constants in def of tameness and Archive according to the final state of the Flyspeck proof. notify = nipkow@in.tum.de [Well_Quasi_Orders] title = Well-Quasi-Orders author = Christian Sternagel date = 2012-04-13 topic = Mathematics/Combinatorics abstract = Based on Isabelle/HOL's type class for preorders, we introduce a type class for well-quasi-orders (wqo) which is characterized by the absence of "bad" sequences (our proofs are along the lines of the proof of Nash-Williams, from which we also borrow terminology). Our main results are instantiations for the product type, the list type, and a type of finite trees, which (almost) directly follow from our proofs of (1) Dickson's Lemma, (2) Higman's Lemma, and (3) Kruskal's Tree Theorem. More concretely:
  • If the sets A and B are wqo then their Cartesian product is wqo.
  • If the set A is wqo then the set of finite lists over A is wqo.
  • If the set A is wqo then the set of finite trees over A is wqo.
The research was funded by the Austrian Science Fund (FWF): J3202. extra-history = Change history: [2012-06-11]: Added Kruskal's Tree Theorem.
[2012-12-19]: New variant of Kruskal's tree theorem for terms (as opposed to variadic terms, i.e., trees), plus finite version of the tree theorem as corollary.
[2013-05-16]: Simplified construction of minimal bad sequences.
[2014-07-09]: Simplified proofs of Higman's lemma and Kruskal's tree theorem, based on homogeneous sequences.
[2016-01-03]: An alternative proof of Higman's lemma by open induction.
[2017-06-08]: Proved (classical) equivalence to inductive definition of almost-full relations according to the ITP 2012 paper "Stop When You Are Almost-Full" by Vytiniotis, Coquand, and Wahlstedt. notify = c.sternagel@gmail.com [Marriage] title = Hall's Marriage Theorem author = Dongchen Jiang , Tobias Nipkow date = 2010-12-17 topic = Mathematics/Combinatorics abstract = Two proofs of Hall's Marriage Theorem: one due to Halmos and Vaughan, one due to Rado. extra-history = Change history: [2011-09-09]: Added Rado's proof notify = nipkow@in.tum.de [Bondy] title = Bondy's Theorem author = Jeremy Avigad , Stefan Hetzl date = 2012-10-27 topic = Mathematics/Combinatorics abstract = A proof of Bondy's theorem following B. Bollabas, Combinatorics, 1986, Cambridge University Press. notify = avigad@cmu.edu, hetzl@logic.at [Ramsey-Infinite] title = Ramsey's theorem, infinitary version author = Tom Ridge <> date = 2004-09-20 topic = Mathematics/Combinatorics abstract = This formalization of Ramsey's theorem (infinitary version) is taken from Boolos and Jeffrey, Computability and Logic, 3rd edition, Chapter 26. It differs slightly from the text by assuming a slightly stronger hypothesis. In particular, the induction hypothesis is stronger, holding for any infinite subset of the naturals. This avoids the rather peculiar mapping argument between kj and aikj on p.263, which is unnecessary and slightly mars this really beautiful result. notify = lp15@cam.ac.uk [Derangements] title = Derangements Formula author = Lukas Bulwahn date = 2015-06-27 topic = Mathematics/Combinatorics abstract = The Derangements Formula describes the number of fixpoint-free permutations as a closed formula. This theorem is the 88th theorem in a list of the ``Top 100 Mathematical Theorems''. notify = lukas.bulwahn@gmail.com [Euler_Partition] title = Euler's Partition Theorem author = Lukas Bulwahn date = 2015-11-19 topic = Mathematics/Combinatorics abstract = Euler's Partition Theorem states that the number of partitions with only distinct parts is equal to the number of partitions with only odd parts. The combinatorial proof follows John Harrison's HOL Light formalization. This theorem is the 45th theorem of the Top 100 Theorems list. notify = lukas.bulwahn@gmail.com [Discrete_Summation] title = Discrete Summation author = Florian Haftmann contributors = Amine Chaieb <> date = 2014-04-13 topic = Mathematics/Combinatorics abstract = These theories introduce basic concepts and proofs about discrete summation: shifts, formal summation, falling factorials and stirling numbers. As proof of concept, a simple summation conversion is provided. notify = florian.haftmann@informatik.tu-muenchen.de [Open_Induction] title = Open Induction author = Mizuhito Ogawa <>, Christian Sternagel date = 2012-11-02 topic = Mathematics/Combinatorics abstract = A proof of the open induction schema based on J.-C. Raoult, Proving open properties by induction, Information Processing Letters 29, 1988, pp.19-23.

This research was supported by the Austrian Science Fund (FWF): J3202.

notify = c.sternagel@gmail.com [Category] title = Category Theory to Yoneda's Lemma author = Greg O'Keefe date = 2005-04-21 topic = Mathematics/Category theory license = LGPL abstract = This development proves Yoneda's lemma and aims to be readable by humans. It only defines what is needed for the lemma: categories, functors and natural transformations. Limits, adjunctions and other important concepts are not included. extra-history = Change history: [2010-04-23]: The definition of the constant equinumerous was slightly too weak in the original submission and has been fixed in revision 8c2b5b3c995f. notify = lcp@cl.cam.ac.uk [Category2] title = Category Theory author = Alexander Katovsky date = 2010-06-20 topic = Mathematics/Category theory abstract = This article presents a development of Category Theory in Isabelle/HOL. A Category is defined using records and locales. Functors and Natural Transformations are also defined. The main result that has been formalized is that the Yoneda functor is a full and faithful embedding. We also formalize the completeness of many sorted monadic equational logic. Extensive use is made of the HOLZF theory in both cases. For an informal description see here [pdf]. notify = alexander.katovsky@cantab.net [FunWithFunctions] title = Fun With Functions author = Tobias Nipkow date = 2008-08-26 topic = Mathematics/Misc abstract = This is a collection of cute puzzles of the form ``Show that if a function satisfies the following constraints, it must be ...'' Please add further examples to this collection! notify = nipkow@in.tum.de [FunWithTilings] title = Fun With Tilings author = Tobias Nipkow , Lawrence C. Paulson date = 2008-11-07 topic = Mathematics/Misc abstract = Tilings are defined inductively. It is shown that one form of mutilated chess board cannot be tiled with dominoes, while another one can be tiled with L-shaped tiles. Please add further fun examples of this kind! notify = nipkow@in.tum.de [Lazy-Lists-II] title = Lazy Lists II author = Stefan Friedrich <> date = 2004-04-26 topic = Computer science/Data structures abstract = This theory contains some useful extensions to the LList (lazy list) theory by Larry Paulson, including finite, infinite, and positive llists over an alphabet, as well as the new constants take and drop and the prefix order of llists. Finally, the notions of safety and liveness in the sense of Alpern and Schneider (1985) are defined. notify = lcp@cl.cam.ac.uk [Ribbon_Proofs] title = Ribbon Proofs author = John Wickerson <> date = 2013-01-19 topic = Computer science/Programming languages/Logics abstract = This document concerns the theory of ribbon proofs: a diagrammatic proof system, based on separation logic, for verifying program correctness. We include the syntax, proof rules, and soundness results for two alternative formalisations of ribbon proofs.

Compared to traditional proof outlines, ribbon proofs emphasise the structure of a proof, so are intelligible and pedagogical. Because they contain less redundancy than proof outlines, and allow each proof step to be checked locally, they may be more scalable. Where proof outlines are cumbersome to modify, ribbon proofs can be visually manoeuvred to yield proofs of variant programs. notify = [Koenigsberg_Friendship] title = The Königsberg Bridge Problem and the Friendship Theorem author = Wenda Li date = 2013-07-19 topic = Mathematics/Graph theory abstract = This development provides a formalization of undirected graphs and simple graphs, which are based on Benedikt Nordhoff and Peter Lammich's simple formalization of labelled directed graphs in the archive. Then, with our formalization of graphs, we show both necessary and sufficient conditions for Eulerian trails and circuits as well as the fact that the Königsberg Bridge Problem does not have a solution. In addition, we show the Friendship Theorem in simple graphs. notify = [Tree_Decomposition] title = Tree Decomposition author = Christoph Dittmann notify = date = 2016-05-31 topic = Mathematics/Graph theory abstract = We formalize tree decompositions and tree width in Isabelle/HOL, proving that trees have treewidth 1. We also show that every edge of a tree decomposition is a separation of the underlying graph. As an application of this theorem we prove that complete graphs of size n have treewidth n-1. [Menger] title = Menger's Theorem author = Christoph Dittmann topic = Mathematics/Graph theory date = 2017-02-26 notify = isabelle@christoph-d.de abstract = We present a formalization of Menger's Theorem for directed and undirected graphs in Isabelle/HOL. This well-known result shows that if two non-adjacent distinct vertices u, v in a directed graph have no separator smaller than n, then there exist n internally vertex-disjoint paths from u to v. The version for undirected graphs follows immediately because undirected graphs are a special case of directed graphs. [IEEE_Floating_Point] title = A Formal Model of IEEE Floating Point Arithmetic author = Lei Yu contributors = Fabian Hellauer , Fabian Immler date = 2013-07-27 topic = Computer science/Data structures abstract = This development provides a formal model of IEEE-754 floating-point arithmetic. This formalization, including formal specification of the standard and proofs of important properties of floating-point arithmetic, forms the foundation for verifying programs with floating-point computation. There is also a code generation setup for floats so that we can execute programs using this formalization in functional programming languages. notify = lp15@cam.ac.uk, immler@in.tum.de extra-history = Change history: [2017-09-25]: Added conversions from and to software floating point numbers (by Fabian Hellauer and Fabian Immler).
[2018-02-05]: 'Modernized' representation following the formalization in HOL4: former "float_format" and predicate "is_valid" is now encoded in a type "('e, 'f) float" where 'e and 'f encode the size of exponent and fraction. [Native_Word] title = Native Word author = Andreas Lochbihler contributors = Peter Lammich date = 2013-09-17 topic = Computer science/Data structures abstract = This entry makes machine words and machine arithmetic available for code generation from Isabelle/HOL. It provides a common abstraction that hides the differences between the different target languages. The code generator maps these operations to the APIs of the target languages. Apart from that, we extend the available bit operations on types int and integer, and map them to the operations in the target languages. extra-history = Change history: [2013-11-06]: added conversion function between native words and characters (revision fd23d9a7fe3a)
[2014-03-31]: added words of default size in the target language (by Peter Lammich) (revision 25caf5065833)
[2014-10-06]: proper test setup with compilation and execution of tests in all target languages (revision 5d7a1c9ae047)
[2017-09-02]: added 64-bit words (revision c89f86244e3c)
[2018-07-15]: added cast operators for default-size words (revision fc1f1fb8dd30)
notify = mail@andreas-lochbihler.de [XML] title = XML author = Christian Sternagel , René Thiemann date = 2014-10-03 topic = Computer science/Functional programming, Computer science/Data structures abstract = This entry provides an XML library for Isabelle/HOL. This includes parsing and pretty printing of XML trees as well as combinators for transforming XML trees into arbitrary user-defined data. The main contribution of this entry is an interface (fit for code generation) that allows for communication between verified programs formalized in Isabelle/HOL and the outside world via XML. This library was developed as part of the IsaFoR/CeTA project to which we refer for examples of its usage. notify = c.sternagel@gmail.com, rene.thiemann@uibk.ac.at [HereditarilyFinite] title = The Hereditarily Finite Sets author = Lawrence C. Paulson date = 2013-11-17 topic = Logic/Set theory abstract = The theory of hereditarily finite sets is formalised, following the development of Swierczkowski. An HF set is a finite collection of other HF sets; they enjoy an induction principle and satisfy all the axioms of ZF set theory apart from the axiom of infinity, which is negated. All constructions that are possible in ZF set theory (Cartesian products, disjoint sums, natural numbers, functions) without using infinite sets are possible here. The definition of addition for the HF sets follows Kirby. This development forms the foundation for the Isabelle proof of Gödel's incompleteness theorems, which has been formalised separately. extra-history = Change history: [2015-02-23]: Added the theory "Finitary" defining the class of types that can be embedded in hf, including int, char, option, list, etc. notify = lp15@cam.ac.uk [Incompleteness] title = Gödel's Incompleteness Theorems author = Lawrence C. Paulson date = 2013-11-17 topic = Logic/Proof theory abstract = Gödel's two incompleteness theorems are formalised, following a careful presentation by Swierczkowski, in the theory of hereditarily finite sets. This represents the first ever machine-assisted proof of the second incompleteness theorem. Compared with traditional formalisations using Peano arithmetic (see e.g. Boolos), coding is simpler, with no need to formalise the notion of multiplication (let alone that of a prime number) in the formalised calculus upon which the theorem is based. However, other technical problems had to be solved in order to complete the argument. notify = lp15@cam.ac.uk [Finite_Automata_HF] title = Finite Automata in Hereditarily Finite Set Theory author = Lawrence C. Paulson date = 2015-02-05 topic = Computer science/Automata and formal languages abstract = Finite Automata, both deterministic and non-deterministic, for regular languages. The Myhill-Nerode Theorem. Closure under intersection, concatenation, etc. Regular expressions define regular languages. Closure under reversal; the powerset construction mapping NFAs to DFAs. Left and right languages; minimal DFAs. Brzozowski's minimization algorithm. Uniqueness up to isomorphism of minimal DFAs. notify = lp15@cam.ac.uk [Decreasing-Diagrams] title = Decreasing Diagrams author = Harald Zankl license = LGPL date = 2013-11-01 topic = Logic/Rewriting abstract = This theory contains a formalization of decreasing diagrams showing that any locally decreasing abstract rewrite system is confluent. We consider the valley (van Oostrom, TCS 1994) and the conversion version (van Oostrom, RTA 2008) and closely follow the original proofs. As an application we prove Newman's lemma. notify = Harald.Zankl@uibk.ac.at [Decreasing-Diagrams-II] title = Decreasing Diagrams II author = Bertram Felgenhauer license = LGPL date = 2015-08-20 topic = Logic/Rewriting abstract = This theory formalizes the commutation version of decreasing diagrams for Church-Rosser modulo. The proof follows Felgenhauer and van Oostrom (RTA 2013). The theory also provides important specializations, in particular van Oostrom’s conversion version (TCS 2008) of decreasing diagrams. notify = bertram.felgenhauer@uibk.ac.at [GoedelGod] title = Gödel's God in Isabelle/HOL author = Christoph Benzmüller , Bruno Woltzenlogel Paleo date = 2013-11-12 topic = Logic/Philosophical aspects abstract = Dana Scott's version of Gödel's proof of God's existence is formalized in quantified modal logic KB (QML KB). QML KB is modeled as a fragment of classical higher-order logic (HOL); thus, the formalization is essentially a formalization in HOL. notify = lp15@cam.ac.uk, c.benzmueller@fu-berlin.de [Types_Tableaus_and_Goedels_God] title = Types, Tableaus and Gödel’s God in Isabelle/HOL author = David Fuenmayor , Christoph Benzmüller topic = Logic/Philosophical aspects date = 2017-05-01 notify = davfuenmayor@gmail.com, c.benzmueller@gmail.com abstract = A computer-formalisation of the essential parts of Fitting's textbook "Types, Tableaus and Gödel's God" in Isabelle/HOL is presented. In particular, Fitting's (and Anderson's) variant of the ontological argument is verified and confirmed. This variant avoids the modal collapse, which has been criticised as an undesirable side-effect of Kurt Gödel's (and Dana Scott's) versions of the ontological argument. Fitting's work is employing an intensional higher-order modal logic, which we shallowly embed here in classical higher-order logic. We then utilize the embedded logic for the formalisation of Fitting's argument. (See also the earlier AFP entry ``Gödel's God in Isabelle/HOL''.) [GewirthPGCProof] title = Formalisation and Evaluation of Alan Gewirth's Proof for the Principle of Generic Consistency in Isabelle/HOL author = David Fuenmayor , Christoph Benzmüller topic = Logic/Philosophical aspects date = 2018-10-30 notify = davfuenmayor@gmail.com, c.benzmueller@gmail.com abstract = An ambitious ethical theory ---Alan Gewirth's "Principle of Generic Consistency"--- is encoded and analysed in Isabelle/HOL. Gewirth's theory has stirred much attention in philosophy and ethics and has been proposed as a potential means to bound the impact of artificial general intelligence. extra-history = Change history: [2019-04-09]: added proof for a stronger variant of the PGC and examplary inferences (revision 88182cb0a2f6)
[Lowe_Ontological_Argument] title = Computer-assisted Reconstruction and Assessment of E. J. Lowe's Modal Ontological Argument author = David Fuenmayor , Christoph Benzmüller topic = Logic/Philosophical aspects date = 2017-09-21 notify = davfuenmayor@gmail.com, c.benzmueller@gmail.com abstract = Computers may help us to understand --not just verify-- philosophical arguments. By utilizing modern proof assistants in an iterative interpretive process, we can reconstruct and assess an argument by fully formal means. Through the mechanization of a variant of St. Anselm's ontological argument by E. J. Lowe, which is a paradigmatic example of a natural-language argument with strong ties to metaphysics and religion, we offer an ideal showcase for our computer-assisted interpretive method. [AnselmGod] title = Anselm's God in Isabelle/HOL author = Ben Blumson topic = Logic/Philosophical aspects date = 2017-09-06 notify = benblumson@gmail.com abstract = Paul Oppenheimer and Edward Zalta's formalisation of Anselm's ontological argument for the existence of God is automated by embedding a free logic for definite descriptions within Isabelle/HOL. [Tail_Recursive_Functions] title = A General Method for the Proof of Theorems on Tail-recursive Functions author = Pasquale Noce date = 2013-12-01 topic = Computer science/Functional programming abstract =

Tail-recursive function definitions are sometimes more straightforward than alternatives, but proving theorems on them may be roundabout because of the peculiar form of the resulting recursion induction rules.

This paper describes a proof method that provides a general solution to this problem by means of suitable invariants over inductive sets, and illustrates the application of such method by examining two case studies.

notify = pasquale.noce.lavoro@gmail.com [CryptoBasedCompositionalProperties] title = Compositional Properties of Crypto-Based Components author = Maria Spichkova date = 2014-01-11 topic = Computer science/Security abstract = This paper presents an Isabelle/HOL set of theories which allows the specification of crypto-based components and the verification of their composition properties wrt. cryptographic aspects. We introduce a formalisation of the security property of data secrecy, the corresponding definitions and proofs. Please note that here we import the Isabelle/HOL theory ListExtras.thy, presented in the AFP entry FocusStreamsCaseStudies-AFP. notify = maria.spichkova@rmit.edu.au [Featherweight_OCL] title = Featherweight OCL: A Proposal for a Machine-Checked Formal Semantics for OCL 2.5 author = Achim D. Brucker , Frédéric Tuong , Burkhart Wolff date = 2014-01-16 topic = Computer science/System description languages abstract = The Unified Modeling Language (UML) is one of the few modeling languages that is widely used in industry. While UML is mostly known as diagrammatic modeling language (e.g., visualizing class models), it is complemented by a textual language, called Object Constraint Language (OCL). The current version of OCL is based on a four-valued logic that turns UML into a formal language. Any type comprises the elements "invalid" and "null" which are propagated as strict and non-strict, respectively. Unfortunately, the former semi-formal semantics of this specification language, captured in the "Annex A" of the OCL standard, leads to different interpretations of corner cases. We formalize the core of OCL: denotational definitions, a logical calculus and operational rules that allow for the execution of OCL expressions by a mixture of term rewriting and code compilation. Our formalization reveals several inconsistencies and contradictions in the current version of the OCL standard. Overall, this document is intended to provide the basis for a machine-checked text "Annex A" of the OCL standard targeting at tool implementors. extra-history = Change history: [2015-10-13]: afp-devel@ea3b38fc54d6 and hol-testgen@12148
   Update of Featherweight OCL including a change in the abstract.
[2014-01-16]: afp-devel@9091ce05cb20 and hol-testgen@10241
   New Entry: Featherweight OCL notify = brucker@spamfence.net, tuong@users.gforge.inria.fr, wolff@lri.fr [Relation_Algebra] title = Relation Algebra author = Alasdair Armstrong <>, Simon Foster , Georg Struth , Tjark Weber date = 2014-01-25 topic = Mathematics/Algebra abstract = Tarski's algebra of binary relations is formalised along the lines of the standard textbooks of Maddux and Schmidt and Ströhlein. This includes relation-algebraic concepts such as subidentities, vectors and a domain operation as well as various notions associated to functions. Relation algebras are also expanded by a reflexive transitive closure operation, and they are linked with Kleene algebras and models of binary relations and Boolean matrices. notify = g.struth@sheffield.ac.uk, tjark.weber@it.uu.se [PSemigroupsConvolution] title = Partial Semigroups and Convolution Algebras author = Brijesh Dongol , Victor B. F. Gomes , Ian J. Hayes , Georg Struth topic = Mathematics/Algebra date = 2017-06-13 notify = g.struth@sheffield.ac.uk, victor.gomes@cl.cam.ac.uk abstract = Partial Semigroups are relevant to the foundations of quantum mechanics and combinatorics as well as to interval and separation logics. Convolution algebras can be understood either as algebras of generalised binary modalities over ternary Kripke frames, in particular over partial semigroups, or as algebras of quantale-valued functions which are equipped with a convolution-style operation of multiplication that is parametrised by a ternary relation. Convolution algebras provide algebraic semantics for various substructural logics, including categorial, relevance and linear logics, for separation logic and for interval logics; they cover quantitative and qualitative applications. These mathematical components for partial semigroups and convolution algebras provide uniform foundations from which models of computation based on relations, program traces or pomsets, and verification components for separation or interval temporal logics can be built with little effort. [Secondary_Sylow] title = Secondary Sylow Theorems author = Jakob von Raumer date = 2014-01-28 topic = Mathematics/Algebra abstract = These theories extend the existing proof of the first Sylow theorem (written by Florian Kammueller and L. C. Paulson) by what are often called the second, third and fourth Sylow theorems. These theorems state propositions about the number of Sylow p-subgroups of a group and the fact that they are conjugate to each other. The proofs make use of an implementation of group actions and their properties. notify = psxjv4@nottingham.ac.uk [Jordan_Hoelder] title = The Jordan-Hölder Theorem author = Jakob von Raumer date = 2014-09-09 topic = Mathematics/Algebra abstract = This submission contains theories that lead to a formalization of the proof of the Jordan-Hölder theorem about composition series of finite groups. The theories formalize the notions of isomorphism classes of groups, simple groups, normal series, composition series, maximal normal subgroups. Furthermore, they provide proofs of the second isomorphism theorem for groups, the characterization theorem for maximal normal subgroups as well as many useful lemmas about normal subgroups and factor groups. The proof is inspired by course notes of Stuart Rankin. notify = psxjv4@nottingham.ac.uk [Cayley_Hamilton] title = The Cayley-Hamilton Theorem author = Stephan Adelsberger , Stefan Hetzl , Florian Pollak date = 2014-09-15 topic = Mathematics/Algebra abstract = This document contains a proof of the Cayley-Hamilton theorem based on the development of matrices in HOL/Multivariate Analysis. notify = stvienna@gmail.com [Probabilistic_Noninterference] title = Probabilistic Noninterference author = Andrei Popescu , Johannes Hölzl date = 2014-03-11 topic = Computer science/Security abstract = We formalize a probabilistic noninterference for a multi-threaded language with uniform scheduling, where probabilistic behaviour comes from both the scheduler and the individual threads. We define notions probabilistic noninterference in two variants: resumption-based and trace-based. For the resumption-based notions, we prove compositionality w.r.t. the language constructs and establish sound type-system-like syntactic criteria. This is a formalization of the mathematical development presented at CPP 2013 and CALCO 2013. It is the probabilistic variant of the Possibilistic Noninterference AFP entry. notify = hoelzl@in.tum.de [HyperCTL] title = A shallow embedding of HyperCTL* author = Markus N. Rabe , Peter Lammich , Andrei Popescu date = 2014-04-16 topic = Computer science/Security, Logic/General logic/Temporal logic abstract = We formalize HyperCTL*, a temporal logic for expressing security properties. We first define a shallow embedding of HyperCTL*, within which we prove inductive and coinductive rules for the operators. Then we show that a HyperCTL* formula captures Goguen-Meseguer noninterference, a landmark information flow property. We also define a deep embedding and connect it to the shallow embedding by a denotational semantics, for which we prove sanity w.r.t. dependence on the free variables. Finally, we show that under some finiteness assumptions about the model, noninterference is given by a (finitary) syntactic formula. notify = uuomul@yahoo.com [Bounded_Deducibility_Security] title = Bounded-Deducibility Security author = Andrei Popescu , Peter Lammich date = 2014-04-22 topic = Computer science/Security abstract = This is a formalization of bounded-deducibility security (BD security), a flexible notion of information-flow security applicable to arbitrary input-output automata. It generalizes Sutherland's classic notion of nondeducibility by factoring in declassification bounds and trigger, whereas nondeducibility states that, in a system, information cannot flow between specified sources and sinks, BD security indicates upper bounds for the flow and triggers under which these upper bounds are no longer guaranteed. notify = uuomul@yahoo.com, lammich@in.tum.de [Network_Security_Policy_Verification] title = Network Security Policy Verification author = Cornelius Diekmann date = 2014-07-04 topic = Computer science/Security abstract = We present a unified theory for verifying network security policies. A security policy is represented as directed graph. To check high-level security goals, security invariants over the policy are expressed. We cover monotonic security invariants, i.e. prohibiting more does not harm security. We provide the following contributions for the security invariant theory.
  • Secure auto-completion of scenario-specific knowledge, which eases usability.
  • Security violations can be repaired by tightening the policy iff the security invariants hold for the deny-all policy.
  • An algorithm to compute a security policy.
  • A formalization of stateful connection semantics in network security mechanisms.
  • An algorithm to compute a secure stateful implementation of a policy.
  • An executable implementation of all the theory.
  • Examples, ranging from an aircraft cabin data network to the analysis of a large real-world firewall.
  • More examples: A fully automated translation of high-level security goals to both firewall and SDN configurations (see Examples/Distributed_WebApp.thy).
For a detailed description, see extra-history = Change history: [2015-04-14]: Added Distributed WebApp example and improved graphviz visualization (revision 4dde08ca2ab8)
notify = diekmann@net.in.tum.de [Abstract_Completeness] title = Abstract Completeness author = Jasmin Christian Blanchette , Andrei Popescu , Dmitriy Traytel date = 2014-04-16 topic = Logic/Proof theory abstract = A formalization of an abstract property of possibly infinite derivation trees (modeled by a codatatype), representing the core of a proof (in Beth/Hintikka style) of the first-order logic completeness theorem, independent of the concrete syntax or inference rules. This work is described in detail in the IJCAR 2014 publication by the authors. The abstract proof can be instantiated for a wide range of Gentzen and tableau systems as well as various flavors of FOL---e.g., with or without predicates, equality, or sorts. Here, we give only a toy example instantiation with classical propositional logic. A more serious instance---many-sorted FOL with equality---is described elsewhere [Blanchette and Popescu, FroCoS 2013]. notify = traytel@in.tum.de [Pop_Refinement] title = Pop-Refinement author = Alessandro Coglio date = 2014-07-03 topic = Computer science/Programming languages/Misc abstract = Pop-refinement is an approach to stepwise refinement, carried out inside an interactive theorem prover by constructing a monotonically decreasing sequence of predicates over deeply embedded target programs. The sequence starts with a predicate that characterizes the possible implementations, and ends with a predicate that characterizes a unique program in explicit syntactic form. Pop-refinement enables more requirements (e.g. program-level and non-functional) to be captured in the initial specification and preserved through refinement. Security requirements expressed as hyperproperties (i.e. predicates over sets of traces) are always preserved by pop-refinement, unlike the popular notion of refinement as trace set inclusion. Two simple examples in Isabelle/HOL are presented, featuring program-level requirements, non-functional requirements, and hyperproperties. notify = coglio@kestrel.edu [VectorSpace] title = Vector Spaces author = Holden Lee date = 2014-08-29 topic = Mathematics/Algebra abstract = This formalisation of basic linear algebra is based completely on locales, building off HOL-Algebra. It includes basic definitions: linear combinations, span, linear independence; linear transformations; interpretation of function spaces as vector spaces; the direct sum of vector spaces, sum of subspaces; the replacement theorem; existence of bases in finite-dimensional; vector spaces, definition of dimension; the rank-nullity theorem. Some concepts are actually defined and proved for modules as they also apply there. Infinite-dimensional vector spaces are supported, but dimension is only supported for finite-dimensional vector spaces. The proofs are standard; the proofs of the replacement theorem and rank-nullity theorem roughly follow the presentation in Linear Algebra by Friedberg, Insel, and Spence. The rank-nullity theorem generalises the existing development in the Archive of Formal Proof (originally using type classes, now using a mix of type classes and locales). notify = holdenl@princeton.edu [Special_Function_Bounds] title = Real-Valued Special Functions: Upper and Lower Bounds author = Lawrence C. Paulson date = 2014-08-29 topic = Mathematics/Analysis abstract = This development proves upper and lower bounds for several familiar real-valued functions. For sin, cos, exp and sqrt, it defines and verifies infinite families of upper and lower bounds, mostly based on Taylor series expansions. For arctan, ln and exp, it verifies a finite collection of upper and lower bounds, originally obtained from the functions' continued fraction expansions using the computer algebra system Maple. A common theme in these proofs is to take the difference between a function and its approximation, which should be zero at one point, and then consider the sign of the derivative. The immediate purpose of this development is to verify axioms used by MetiTarski, an automatic theorem prover for real-valued special functions. Crucial to MetiTarski's operation is the provision of upper and lower bounds for each function of interest. notify = lp15@cam.ac.uk [Landau_Symbols] title = Landau Symbols author = Manuel Eberl date = 2015-07-14 topic = Mathematics/Analysis abstract = This entry provides Landau symbols to describe and reason about the asymptotic growth of functions for sufficiently large inputs. A number of simplification procedures are provided for additional convenience: cancelling of dominated terms in sums under a Landau symbol, cancelling of common factors in products, and a decision procedure for Landau expressions containing products of powers of functions like x, ln(x), ln(ln(x)) etc. notify = eberlm@in.tum.de [Error_Function] title = The Error Function author = Manuel Eberl topic = Mathematics/Analysis date = 2018-02-06 notify = eberlm@in.tum.de abstract =

This entry provides the definitions and basic properties of the complex and real error function erf and the complementary error function erfc. Additionally, it gives their full asymptotic expansions.

[Akra_Bazzi] title = The Akra-Bazzi theorem and the Master theorem author = Manuel Eberl date = 2015-07-14 topic = Mathematics/Analysis abstract = This article contains a formalisation of the Akra-Bazzi method based on a proof by Leighton. It is a generalisation of the well-known Master Theorem for analysing the complexity of Divide & Conquer algorithms. We also include a generalised version of the Master theorem based on the Akra-Bazzi theorem, which is easier to apply than the Akra-Bazzi theorem itself.

Some proof methods that facilitate applying the Master theorem are also included. For a more detailed explanation of the formalisation and the proof methods, see the accompanying paper (publication forthcoming). notify = eberlm@in.tum.de [Dirichlet_Series] title = Dirichlet Series author = Manuel Eberl topic = Mathematics/Number theory date = 2017-10-12 notify = eberlm@in.tum.de abstract = This entry is a formalisation of much of Chapters 2, 3, and 11 of Apostol's “Introduction to Analytic Number Theory”. This includes:

  • Definitions and basic properties for several number-theoretic functions (Euler's φ, Möbius μ, Liouville's λ, the divisor function σ, von Mangoldt's Λ)
  • Executable code for most of these functions, the most efficient implementations using the factoring algorithm by Thiemann et al.
  • Dirichlet products and formal Dirichlet series
  • Analytic results connecting convergent formal Dirichlet series to complex functions
  • Euler product expansions
  • Asymptotic estimates of number-theoretic functions including the density of squarefree integers and the average number of divisors of a natural number
These results are useful as a basis for developing more number-theoretic results, such as the Prime Number Theorem. [Gauss_Sums] title = Gauss Sums and the Pólya–Vinogradov Inequality author = Rodrigo Raya , Manuel Eberl topic = Mathematics/Number theory date = 2019-12-10 notify = manuel.eberl@tum.de abstract =

This article provides a full formalisation of Chapter 8 of Apostol's Introduction to Analytic Number Theory. Subjects that are covered are:

  • periodic arithmetic functions and their finite Fourier series
  • (generalised) Ramanujan sums
  • Gauss sums and separable characters
  • induced moduli and primitive characters
  • the Pólya—Vinogradov inequality
[Zeta_Function] title = The Hurwitz and Riemann ζ Functions author = Manuel Eberl topic = Mathematics/Number theory, Mathematics/Analysis date = 2017-10-12 notify = eberlm@in.tum.de abstract =

This entry builds upon the results about formal and analytic Dirichlet series to define the Hurwitz ζ function ζ(a,s) and, based on that, the Riemann ζ function ζ(s). This is done by first defining them for ℜ(z) > 1 and then successively extending the domain to the left using the Euler–MacLaurin formula.

Apart from the most basic facts such as analyticity, the following results are provided:

  • the Stieltjes constants and the Laurent expansion of ζ(s) at s = 1
  • the non-vanishing of ζ(s) for ℜ(z) ≥ 1
  • the relationship between ζ(a,s) and Γ
  • the special values at negative integers and positive even integers
  • Hurwitz's formula and the reflection formula for ζ(s)
  • the Hadjicostas–Chapman formula

The entry also contains Euler's analytic proof of the infinitude of primes, based on the fact that ζ(s) has a pole at s = 1.

[Linear_Recurrences] title = Linear Recurrences author = Manuel Eberl topic = Mathematics/Analysis date = 2017-10-12 notify = eberlm@in.tum.de abstract =

Linear recurrences with constant coefficients are an interesting class of recurrence equations that can be solved explicitly. The most famous example are certainly the Fibonacci numbers with the equation f(n) = f(n-1) + f(n - 2) and the quite non-obvious closed form (φn - (-φ)-n) / √5 where φ is the golden ratio.

In this work, I build on existing tools in Isabelle – such as formal power series and polynomial factorisation algorithms – to develop a theory of these recurrences and derive a fully executable solver for them that can be exported to programming languages like Haskell.

[Lambert_W] title = The Lambert W Function on the Reals author = Manuel Eberl topic = Mathematics/Analysis date = 2020-04-24 notify = eberlm@in.tum.de abstract =

The Lambert W function is a multi-valued function defined as the inverse function of x ↦ x ex. Besides numerous applications in combinatorics, physics, and engineering, it also frequently occurs when solving equations containing both ex and x, or both x and log x.

This article provides a definition of the two real-valued branches W0(x) and W-1(x) and proves various properties such as basic identities and inequalities, monotonicity, differentiability, asymptotic expansions, and the MacLaurin series of W0(x) at x = 0.

[Cartan_FP] title = The Cartan Fixed Point Theorems author = Lawrence C. Paulson date = 2016-03-08 topic = Mathematics/Analysis abstract = The Cartan fixed point theorems concern the group of holomorphic automorphisms on a connected open set of Cn. Ciolli et al. have formalised the one-dimensional case of these theorems in HOL Light. This entry contains their proofs, ported to Isabelle/HOL. Thus it addresses the authors' remark that "it would be important to write a formal proof in a language that can be read by both humans and machines". notify = lp15@cam.ac.uk [Gauss_Jordan] title = Gauss-Jordan Algorithm and Its Applications author = Jose Divasón , Jesús Aransay topic = Computer science/Algorithms/Mathematical date = 2014-09-03 abstract = The Gauss-Jordan algorithm states that any matrix over a field can be transformed by means of elementary row operations to a matrix in reduced row echelon form. The formalization is based on the Rank Nullity Theorem entry of the AFP and on the HOL-Multivariate-Analysis session of Isabelle, where matrices are represented as functions over finite types. We have set up the code generator to make this representation executable. In order to improve the performance, a refinement to immutable arrays has been carried out. We have formalized some of the applications of the Gauss-Jordan algorithm. Thanks to this development, the following facts can be computed over matrices whose elements belong to a field: Ranks, Determinants, Inverses, Bases and dimensions and Solutions of systems of linear equations. Code can be exported to SML and Haskell. notify = jose.divasonm@unirioja.es, jesus-maria.aransay@unirioja.es [Echelon_Form] title = Echelon Form author = Jose Divasón , Jesús Aransay topic = Computer science/Algorithms/Mathematical, Mathematics/Algebra date = 2015-02-12 abstract = We formalize an algorithm to compute the Echelon Form of a matrix. We have proved its existence over Bézout domains and made it executable over Euclidean domains, such as the integer ring and the univariate polynomials over a field. This allows us to compute determinants, inverses and characteristic polynomials of matrices. The work is based on the HOL-Multivariate Analysis library, and on both the Gauss-Jordan and Cayley-Hamilton AFP entries. As a by-product, some algebraic structures have been implemented (principal ideal domains, Bézout domains...). The algorithm has been refined to immutable arrays and code can be generated to functional languages as well. notify = jose.divasonm@unirioja.es, jesus-maria.aransay@unirioja.es [QR_Decomposition] title = QR Decomposition author = Jose Divasón , Jesús Aransay topic = Computer science/Algorithms/Mathematical, Mathematics/Algebra date = 2015-02-12 abstract = QR decomposition is an algorithm to decompose a real matrix A into the product of two other matrices Q and R, where Q is orthogonal and R is invertible and upper triangular. The algorithm is useful for the least squares problem; i.e., the computation of the best approximation of an unsolvable system of linear equations. As a side-product, the Gram-Schmidt process has also been formalized. A refinement using immutable arrays is presented as well. The development relies, among others, on the AFP entry "Implementing field extensions of the form Q[sqrt(b)]" by René Thiemann, which allows execution of the algorithm using symbolic computations. Verified code can be generated and executed using floats as well. extra-history = Change history: [2015-06-18]: The second part of the Fundamental Theorem of Linear Algebra has been generalized to more general inner product spaces. notify = jose.divasonm@unirioja.es, jesus-maria.aransay@unirioja.es [Hermite] title = Hermite Normal Form author = Jose Divasón , Jesús Aransay topic = Computer science/Algorithms/Mathematical, Mathematics/Algebra date = 2015-07-07 abstract = Hermite Normal Form is a canonical matrix analogue of Reduced Echelon Form, but involving matrices over more general rings. In this work we formalise an algorithm to compute the Hermite Normal Form of a matrix by means of elementary row operations, taking advantage of the Echelon Form AFP entry. We have proven the correctness of such an algorithm and refined it to immutable arrays. Furthermore, we have also formalised the uniqueness of the Hermite Normal Form of a matrix. Code can be exported and some examples of execution involving integer matrices and polynomial matrices are presented as well. notify = jose.divasonm@unirioja.es, jesus-maria.aransay@unirioja.es [Imperative_Insertion_Sort] title = Imperative Insertion Sort author = Christian Sternagel date = 2014-09-25 topic = Computer science/Algorithms abstract = The insertion sort algorithm of Cormen et al. (Introduction to Algorithms) is expressed in Imperative HOL and proved to be correct and terminating. For this purpose we also provide a theory about imperative loop constructs with accompanying induction/invariant rules for proving partial and total correctness. Furthermore, the formalized algorithm is fit for code generation. notify = lp15@cam.ac.uk [Stream_Fusion_Code] title = Stream Fusion in HOL with Code Generation author = Andreas Lochbihler , Alexandra Maximova date = 2014-10-10 topic = Computer science/Functional programming abstract = Stream Fusion is a system for removing intermediate list data structures from functional programs, in particular Haskell. This entry adapts stream fusion to Isabelle/HOL and its code generator. We define stream types for finite and possibly infinite lists and stream versions for most of the fusible list functions in the theories List and Coinductive_List, and prove them correct with respect to the conversion functions between lists and streams. The Stream Fusion transformation itself is implemented as a simproc in the preprocessor of the code generator. [Brian Huffman's AFP entry formalises stream fusion in HOLCF for the domain of lazy lists to prove the GHC compiler rewrite rules correct. In contrast, this work enables Isabelle's code generator to perform stream fusion itself. To that end, it covers both finite and coinductive lists from the HOL library and the Coinductive entry. The fusible list functions require specification and proof principles different from Huffman's.] notify = mail@andreas-lochbihler.de [Case_Labeling] title = Generating Cases from Labeled Subgoals author = Lars Noschinski date = 2015-07-21 topic = Tools, Computer science/Programming languages/Misc abstract = Isabelle/Isar provides named cases to structure proofs. This article contains an implementation of a proof method casify, which can be used to easily extend proof tools with support for named cases. Such a proof tool must produce labeled subgoals, which are then interpreted by casify.

As examples, this work contains verification condition generators producing named cases for three languages: The Hoare language from HOL/Library, a monadic language for computations with failure (inspired by the AutoCorres tool), and a language of conditional expressions. These VCGs are demonstrated by a number of example programs. notify = noschinl@gmail.com [DPT-SAT-Solver] title = A Fast SAT Solver for Isabelle in Standard ML topic = Tools author = Armin Heller <> date = 2009-12-09 abstract = This contribution contains a fast SAT solver for Isabelle written in Standard ML. By loading the theory DPT_SAT_Solver, the SAT solver installs itself (under the name ``dptsat'') and certain Isabelle tools like Refute will start using it automatically. This is a port of the DPT (Decision Procedure Toolkit) SAT Solver written in OCaml. notify = jasmin.blanchette@gmail.com [Rep_Fin_Groups] title = Representations of Finite Groups topic = Mathematics/Algebra author = Jeremy Sylvestre date = 2015-08-12 abstract = We provide a formal framework for the theory of representations of finite groups, as modules over the group ring. Along the way, we develop the general theory of groups (relying on the group_add class for the basics), modules, and vector spaces, to the extent required for theory of group representations. We then provide formal proofs of several important introductory theorems in the subject, including Maschke's theorem, Schur's lemma, and Frobenius reciprocity. We also prove that every irreducible representation is isomorphic to a submodule of the group ring, leading to the fact that for a finite group there are only finitely many isomorphism classes of irreducible representations. In all of this, no restriction is made on the characteristic of the ring or field of scalars until the definition of a group representation, and then the only restriction made is that the characteristic must not divide the order of the group. notify = jsylvest@ualberta.ca [Noninterference_Inductive_Unwinding] title = The Inductive Unwinding Theorem for CSP Noninterference Security topic = Computer science/Security author = Pasquale Noce date = 2015-08-18 abstract =

The necessary and sufficient condition for CSP noninterference security stated by the Ipurge Unwinding Theorem is expressed in terms of a pair of event lists varying over the set of process traces. This does not render it suitable for the subsequent application of rule induction in the case of a process defined inductively, since rule induction may rather be applied to a single variable ranging over an inductively defined set.

Starting from the Ipurge Unwinding Theorem, this paper derives a necessary and sufficient condition for CSP noninterference security that involves a single event list varying over the set of process traces, and is thus suitable for rule induction; hence its name, Inductive Unwinding Theorem. Similarly to the Ipurge Unwinding Theorem, the new theorem only requires to consider individual accepted and refused events for each process trace, and applies to the general case of a possibly intransitive noninterference policy. Specific variants of this theorem are additionally proven for deterministic processes and trace set processes.

notify = pasquale.noce.lavoro@gmail.com [Password_Authentication_Protocol] title = Verification of a Diffie-Hellman Password-based Authentication Protocol by Extending the Inductive Method author = Pasquale Noce topic = Computer science/Security date = 2017-01-03 notify = pasquale.noce.lavoro@gmail.com abstract = This paper constructs a formal model of a Diffie-Hellman password-based authentication protocol between a user and a smart card, and proves its security. The protocol provides for the dispatch of the user's password to the smart card on a secure messaging channel established by means of Password Authenticated Connection Establishment (PACE), where the mapping method being used is Chip Authentication Mapping. By applying and suitably extending Paulson's Inductive Method, this paper proves that the protocol establishes trustworthy secure messaging channels, preserves the secrecy of users' passwords, and provides an effective mutual authentication service. What is more, these security properties turn out to hold independently of the secrecy of the PACE authentication key. [Jordan_Normal_Form] title = Matrices, Jordan Normal Forms, and Spectral Radius Theory topic = Mathematics/Algebra author = René Thiemann , Akihisa Yamada contributors = Alexander Bentkamp date = 2015-08-21 abstract =

Matrix interpretations are useful as measure functions in termination proving. In order to use these interpretations also for complexity analysis, the growth rate of matrix powers has to examined. Here, we formalized a central result of spectral radius theory, namely that the growth rate is polynomially bounded if and only if the spectral radius of a matrix is at most one.

To formally prove this result we first studied the growth rates of matrices in Jordan normal form, and prove the result that every complex matrix has a Jordan normal form using a constructive prove via Schur decomposition.

The whole development is based on a new abstract type for matrices, which is also executable by a suitable setup of the code generator. It completely subsumes our former AFP-entry on executable matrices, and its main advantage is its close connection to the HMA-representation which allowed us to easily adapt existing proofs on determinants.

All the results have been applied to improve CeTA, our certifier to validate termination and complexity proof certificates.

extra-history = Change history: [2016-01-07]: Added Schur-decomposition, Gram-Schmidt orthogonalization, uniqueness of Jordan normal forms
[2018-04-17]: Integrated lemmas from deep-learning AFP-entry of Alexander Bentkamp notify = rene.thiemann@uibk.ac.at, ayamada@trs.cm.is.nagoya-u.ac.jp [LTL_to_DRA] title = Converting Linear Temporal Logic to Deterministic (Generalized) Rabin Automata topic = Computer science/Automata and formal languages author = Salomon Sickert date = 2015-09-04 abstract = Recently, Javier Esparza and Jan Kretinsky proposed a new method directly translating linear temporal logic (LTL) formulas to deterministic (generalized) Rabin automata. Compared to the existing approaches of constructing a non-deterministic Buechi-automaton in the first step and then applying a determinization procedure (e.g. some variant of Safra's construction) in a second step, this new approach preservers a relation between the formula and the states of the resulting automaton. While the old approach produced a monolithic structure, the new method is compositional. Furthermore, in some cases the resulting automata are much smaller than the automata generated by existing approaches. In order to ensure the correctness of the construction, this entry contains a complete formalisation and verification of the translation. Furthermore from this basis executable code is generated. extra-history = Change history: [2015-09-23]: Enable code export for the eager unfolding optimisation and reduce running time of the generated tool. Moreover, add support for the mlton SML compiler.
[2016-03-24]: Make use of the LTL entry and include the simplifier. notify = sickert@in.tum.de [Timed_Automata] title = Timed Automata author = Simon Wimmer date = 2016-03-08 topic = Computer science/Automata and formal languages abstract = Timed automata are a widely used formalism for modeling real-time systems, which is employed in a class of successful model checkers such as UPPAAL [LPY97], HyTech [HHWt97] or Kronos [Yov97]. This work formalizes the theory for the subclass of diagonal-free timed automata, which is sufficient to model many interesting problems. We first define the basic concepts and semantics of diagonal-free timed automata. Based on this, we prove two types of decidability results for the language emptiness problem. The first is the classic result of Alur and Dill [AD90, AD94], which uses a finite partitioning of the state space into so-called `regions`. Our second result focuses on an approach based on `Difference Bound Matrices (DBMs)`, which is practically used by model checkers. We prove the correctness of the basic forward analysis operations on DBMs. One of these operations is the Floyd-Warshall algorithm for the all-pairs shortest paths problem. To obtain a finite search space, a widening operation has to be used for this kind of analysis. We use Patricia Bouyer's [Bou04] approach to prove that this widening operation is correct in the sense that DBM-based forward analysis in combination with the widening operation also decides language emptiness. The interesting property of this proof is that the first decidability result is reused to obtain the second one. notify = wimmers@in.tum.de [Parity_Game] title = Positional Determinacy of Parity Games author = Christoph Dittmann date = 2015-11-02 topic = Mathematics/Games and economics, Mathematics/Graph theory abstract = We present a formalization of parity games (a two-player game on directed graphs) and a proof of their positional determinacy in Isabelle/HOL. This proof works for both finite and infinite games. notify = [Ergodic_Theory] title = Ergodic Theory author = Sebastien Gouezel date = 2015-12-01 topic = Mathematics/Probability theory abstract = Ergodic theory is the branch of mathematics that studies the behaviour of measure preserving transformations, in finite or infinite measure. It interacts both with probability theory (mainly through measure theory) and with geometry as a lot of interesting examples are from geometric origin. We implement the first definitions and theorems of ergodic theory, including notably Poicaré recurrence theorem for finite measure preserving systems (together with the notion of conservativity in general), induced maps, Kac's theorem, Birkhoff theorem (arguably the most important theorem in ergodic theory), and variations around it such as conservativity of the corresponding skew product, or Atkinson lemma. notify = sebastien.gouezel@univ-rennes1.fr, hoelzl@in.tum.de [Latin_Square] title = Latin Square author = Alexander Bentkamp date = 2015-12-02 topic = Mathematics/Combinatorics abstract = A Latin Square is a n x n table filled with integers from 1 to n where each number appears exactly once in each row and each column. A Latin Rectangle is a partially filled n x n table with r filled rows and n-r empty rows, such that each number appears at most once in each row and each column. The main result of this theory is that any Latin Rectangle can be completed to a Latin Square. notify = bentkamp@gmail.com [Deep_Learning] title = Expressiveness of Deep Learning author = Alexander Bentkamp date = 2016-11-10 topic = Computer science/Machine learning, Mathematics/Analysis abstract = Deep learning has had a profound impact on computer science in recent years, with applications to search engines, image recognition and language processing, bioinformatics, and more. Recently, Cohen et al. provided theoretical evidence for the superiority of deep learning over shallow learning. This formalization of their work simplifies and generalizes the original proof, while working around the limitations of the Isabelle type system. To support the formalization, I developed reusable libraries of formalized mathematics, including results about the matrix rank, the Lebesgue measure, and multivariate polynomials, as well as a library for tensor analysis. notify = bentkamp@gmail.com [Applicative_Lifting] title = Applicative Lifting author = Andreas Lochbihler , Joshua Schneider <> date = 2015-12-22 topic = Computer science/Functional programming abstract = Applicative functors augment computations with effects by lifting function application to types which model the effects. As the structure of the computation cannot depend on the effects, applicative expressions can be analysed statically. This allows us to lift universally quantified equations to the effectful types, as observed by Hinze. Thus, equational reasoning over effectful computations can be reduced to pure types.

This entry provides a package for registering applicative functors and two proof methods for lifting of equations over applicative functors. The first method normalises applicative expressions according to the laws of applicative functors. This way, equations whose two sides contain the same list of variables can be lifted to every applicative functor.

To lift larger classes of equations, the second method exploits a number of additional properties (e.g., commutativity of effects) provided the properties have been declared for the concrete applicative functor at hand upon registration.

We declare several types from the Isabelle library as applicative functors and illustrate the use of the methods with two examples: the lifting of the arithmetic type class hierarchy to streams and the verification of a relabelling function on binary trees. We also formalise and verify the normalisation algorithm used by the first proof method.

extra-history = Change history: [2016-03-03]: added formalisation of lifting with combinators
[2016-06-10]: implemented automatic derivation of lifted combinator reductions; support arbitrary lifted relations using relators; improved compatibility with locale interpretation (revision ec336f354f37)
notify = mail@andreas-lochbihler.de [Stern_Brocot] title = The Stern-Brocot Tree author = Peter Gammie , Andreas Lochbihler date = 2015-12-22 topic = Mathematics/Number theory abstract = The Stern-Brocot tree contains all rational numbers exactly once and in their lowest terms. We formalise the Stern-Brocot tree as a coinductive tree using recursive and iterative specifications, which we have proven equivalent, and show that it indeed contains all the numbers as stated. Following Hinze, we prove that the Stern-Brocot tree can be linearised looplessly into Stern's diatonic sequence (also known as Dijkstra's fusc function) and that it is a permutation of the Bird tree.

The reasoning stays at an abstract level by appealing to the uniqueness of solutions of guarded recursive equations and lifting algebraic laws point-wise to trees and streams using applicative functors.

notify = mail@andreas-lochbihler.de [Algebraic_Numbers] title = Algebraic Numbers in Isabelle/HOL topic = Mathematics/Algebra author = René Thiemann , Akihisa Yamada , Sebastiaan Joosten date = 2015-12-22 abstract = Based on existing libraries for matrices, factorization of rational polynomials, and Sturm's theorem, we formalized algebraic numbers in Isabelle/HOL. Our development serves as an implementation for real and complex numbers, and it admits to compute roots and completely factorize real and complex polynomials, provided that all coefficients are rational numbers. Moreover, we provide two implementations to display algebraic numbers, an injective and expensive one, or a faster but approximative version.

To this end, we mechanized several results on resultants, which also required us to prove that polynomials over a unique factorization domain form again a unique factorization domain.

extra-history = Change history: [2016-01-29]: Split off Polynomial Interpolation and Polynomial Factorization
[2017-04-16]: Use certified Berlekamp-Zassenhaus factorization, use subresultant algorithm for computing resultants, improved bisection algorithm notify = rene.thiemann@uibk.ac.at, ayamada@trs.cm.is.nagoya-u.ac.jp, sebastiaan.joosten@uibk.ac.at [Polynomial_Interpolation] title = Polynomial Interpolation topic = Mathematics/Algebra author = René Thiemann , Akihisa Yamada date = 2016-01-29 abstract = We formalized three algorithms for polynomial interpolation over arbitrary fields: Lagrange's explicit expression, the recursive algorithm of Neville and Aitken, and the Newton interpolation in combination with an efficient implementation of divided differences. Variants of these algorithms for integer polynomials are also available, where sometimes the interpolation can fail; e.g., there is no linear integer polynomial p such that p(0) = 0 and p(2) = 1. Moreover, for the Newton interpolation for integer polynomials, we proved that all intermediate results that are computed during the algorithm must be integers. This admits an early failure detection in the implementation. Finally, we proved the uniqueness of polynomial interpolation.

The development also contains improved code equations to speed up the division of integers in target languages. notify = rene.thiemann@uibk.ac.at, ayamada@trs.cm.is.nagoya-u.ac.jp [Polynomial_Factorization] title = Polynomial Factorization topic = Mathematics/Algebra author = René Thiemann , Akihisa Yamada date = 2016-01-29 abstract = Based on existing libraries for polynomial interpolation and matrices, we formalized several factorization algorithms for polynomials, including Kronecker's algorithm for integer polynomials, Yun's square-free factorization algorithm for field polynomials, and Berlekamp's algorithm for polynomials over finite fields. By combining the last one with Hensel's lifting, we derive an efficient factorization algorithm for the integer polynomials, which is then lifted for rational polynomials by mechanizing Gauss' lemma. Finally, we assembled a combined factorization algorithm for rational polynomials, which combines all the mentioned algorithms and additionally uses the explicit formula for roots of quadratic polynomials and a rational root test.

As side products, we developed division algorithms for polynomials over integral domains, as well as primality-testing and prime-factorization algorithms for integers. notify = rene.thiemann@uibk.ac.at, ayamada@trs.cm.is.nagoya-u.ac.jp [Perron_Frobenius] title = Perron-Frobenius Theorem for Spectral Radius Analysis author = Jose Divasón , Ondřej Kunčar , René Thiemann , Akihisa Yamada notify = rene.thiemann@uibk.ac.at date = 2016-05-20 topic = Mathematics/Algebra abstract =

The spectral radius of a matrix A is the maximum norm of all eigenvalues of A. In previous work we already formalized that for a complex matrix A, the values in An grow polynomially in n if and only if the spectral radius is at most one. One problem with the above characterization is the determination of all complex eigenvalues. In case A contains only non-negative real values, a simplification is possible with the help of the Perron–Frobenius theorem, which tells us that it suffices to consider only the real eigenvalues of A, i.e., applying Sturm's method can decide the polynomial growth of An.

We formalize the Perron–Frobenius theorem based on a proof via Brouwer's fixpoint theorem, which is available in the HOL multivariate analysis (HMA) library. Since the results on the spectral radius is based on matrices in the Jordan normal form (JNF) library, we further develop a connection which allows us to easily transfer theorems between HMA and JNF. With this connection we derive the combined result: if A is a non-negative real matrix, and no real eigenvalue of A is strictly larger than one, then An is polynomially bounded in n.

extra-history = Change history: [2017-10-18]: added Perron-Frobenius theorem for irreducible matrices with generalization (revision bda1f1ce8a1c)
[2018-05-17]: prove conjecture of CPP'18 paper: Jordan blocks of spectral radius have maximum size (revision ffdb3794e5d5) [Stochastic_Matrices] title = Stochastic Matrices and the Perron-Frobenius Theorem author = René Thiemann topic = Mathematics/Algebra, Computer science/Automata and formal languages date = 2017-11-22 notify = rene.thiemann@uibk.ac.at abstract = Stochastic matrices are a convenient way to model discrete-time and finite state Markov chains. The Perron–Frobenius theorem tells us something about the existence and uniqueness of non-negative eigenvectors of a stochastic matrix. In this entry, we formalize stochastic matrices, link the formalization to the existing AFP-entry on Markov chains, and apply the Perron–Frobenius theorem to prove that stationary distributions always exist, and they are unique if the stochastic matrix is irreducible. [Formal_SSA] title = Verified Construction of Static Single Assignment Form author = Sebastian Ullrich , Denis Lohner date = 2016-02-05 topic = Computer science/Algorithms, Computer science/Programming languages/Transformations abstract =

We define a functional variant of the static single assignment (SSA) form construction algorithm described by Braun et al., which combines simplicity and efficiency. The definition is based on a general, abstract control flow graph representation using Isabelle locales.

We prove that the algorithm's output is semantically equivalent to the input according to a small-step semantics, and that it is in minimal SSA form for the common special case of reducible inputs. We then show the satisfiability of the locale assumptions by giving instantiations for a simple While language.

Furthermore, we use a generic instantiation based on typedefs in order to extract OCaml code and replace the unverified SSA construction algorithm of the CompCertSSA project with it.

A more detailed description of the verified SSA construction can be found in the paper Verified Construction of Static Single Assignment Form, CC 2016.

notify = denis.lohner@kit.edu [Minimal_SSA] title = Minimal Static Single Assignment Form author = Max Wagner , Denis Lohner topic = Computer science/Programming languages/Transformations date = 2017-01-17 notify = denis.lohner@kit.edu abstract =

This formalization is an extension to "Verified Construction of Static Single Assignment Form". In their work, the authors have shown that Braun et al.'s static single assignment (SSA) construction algorithm produces minimal SSA form for input programs with a reducible control flow graph (CFG). However Braun et al. also proposed an extension to their algorithm that they claim produces minimal SSA form even for irreducible CFGs.
In this formalization we support that claim by giving a mechanized proof.

As the extension of Braun et al.'s algorithm aims for removing so-called redundant strongly connected components of phi functions, we show that this suffices to guarantee minimality according to Cytron et al..

[PropResPI] title = Propositional Resolution and Prime Implicates Generation author = Nicolas Peltier notify = Nicolas.Peltier@imag.fr date = 2016-03-11 topic = Logic/General logic/Mechanization of proofs abstract = We provide formal proofs in Isabelle-HOL (using mostly structured Isar proofs) of the soundness and completeness of the Resolution rule in propositional logic. The completeness proofs take into account the usual redundancy elimination rules (tautology elimination and subsumption), and several refinements of the Resolution rule are considered: ordered resolution (with selection functions), positive and negative resolution, semantic resolution and unit resolution (the latter refinement is complete only for clause sets that are Horn- renamable). We also define a concrete procedure for computing saturated sets and establish its soundness and completeness. The clause sets are not assumed to be finite, so that the results can be applied to formulas obtained by grounding sets of first-order clauses (however, a total ordering among atoms is assumed to be given). Next, we show that the unrestricted Resolution rule is deductive- complete, in the sense that it is able to generate all (prime) implicates of any set of propositional clauses (i.e., all entailment- minimal, non-valid, clausal consequences of the considered set). The generation of prime implicates is an important problem, with many applications in artificial intelligence and verification (for abductive reasoning, knowledge compilation, diagnosis, debugging etc.). We also show that implicates can be computed in an incremental way, by fixing an ordering among all the atoms in the considered sets and resolving upon these atoms one by one in the considered order (with no backtracking). This feature is critical for the efficient computation of prime implicates. Building on these results, we provide a procedure for computing such implicates and establish its soundness and completeness. [SuperCalc] title = A Variant of the Superposition Calculus author = Nicolas Peltier notify = Nicolas.Peltier@imag.fr date = 2016-09-06 topic = Logic/Proof theory abstract = We provide a formalization of a variant of the superposition calculus, together with formal proofs of soundness and refutational completeness (w.r.t. the usual redundancy criteria based on clause ordering). This version of the calculus uses all the standard restrictions of the superposition rules, together with the following refinement, inspired by the basic superposition calculus: each clause is associated with a set of terms which are assumed to be in normal form -- thus any application of the replacement rule on these terms is blocked. The set is initially empty and terms may be added or removed at each inference step. The set of terms that are assumed to be in normal form includes any term introduced by previous unifiers as well as any term occurring in the parent clauses at a position that is smaller (according to some given ordering on positions) than a previously replaced term. The standard superposition calculus corresponds to the case where the set of irreducible terms is always empty. [Nominal2] title = Nominal 2 author = Christian Urban , Stefan Berghofer , Cezary Kaliszyk date = 2013-02-21 topic = Tools abstract =

Dealing with binders, renaming of bound variables, capture-avoiding substitution, etc., is very often a major problem in formal proofs, especially in proofs by structural and rule induction. Nominal Isabelle is designed to make such proofs easy to formalise: it provides an infrastructure for declaring nominal datatypes (that is alpha-equivalence classes) and for defining functions over them by structural recursion. It also provides induction principles that have Barendregt’s variable convention already built in.

This entry can be used as a more advanced replacement for HOL/Nominal in the Isabelle distribution.

notify = christian.urban@kcl.ac.uk [First_Welfare_Theorem] title = Microeconomics and the First Welfare Theorem author = Julian Parsert , Cezary Kaliszyk topic = Mathematics/Games and economics license = LGPL date = 2017-09-01 notify = julian.parsert@uibk.ac.at, cezary.kaliszyk@uibk.ac.at abstract = Economic activity has always been a fundamental part of society. Due to modern day politics, economic theory has gained even more influence on our lives. Thus we want models and theories to be as precise as possible. This can be achieved using certification with the help of formal proof technology. Hence we will use Isabelle/HOL to construct two economic models, that of the the pure exchange economy and a version of the Arrow-Debreu Model. We will prove that the First Theorem of Welfare Economics holds within both. The theorem is the mathematical formulation of Adam Smith's famous invisible hand and states that a group of self-interested and rational actors will eventually achieve an efficient allocation of goods and services. extra-history = Change history: [2018-06-17]: Added some lemmas and a theory file, also introduced Microeconomics folder.
[Noninterference_Sequential_Composition] title = Conservation of CSP Noninterference Security under Sequential Composition author = Pasquale Noce date = 2016-04-26 topic = Computer science/Security, Computer science/Concurrency/Process calculi abstract =

In his outstanding work on Communicating Sequential Processes, Hoare has defined two fundamental binary operations allowing to compose the input processes into another, typically more complex, process: sequential composition and concurrent composition. Particularly, the output of the former operation is a process that initially behaves like the first operand, and then like the second operand once the execution of the first one has terminated successfully, as long as it does.

This paper formalizes Hoare's definition of sequential composition and proves, in the general case of a possibly intransitive policy, that CSP noninterference security is conserved under this operation, provided that successful termination cannot be affected by confidential events and cannot occur as an alternative to other events in the traces of the first operand. Both of these assumptions are shown, by means of counterexamples, to be necessary for the theorem to hold.

notify = pasquale.noce.lavoro@gmail.com [Noninterference_Concurrent_Composition] title = Conservation of CSP Noninterference Security under Concurrent Composition author = Pasquale Noce notify = pasquale.noce.lavoro@gmail.com date = 2016-06-13 topic = Computer science/Security, Computer science/Concurrency/Process calculi abstract =

In his outstanding work on Communicating Sequential Processes, Hoare has defined two fundamental binary operations allowing to compose the input processes into another, typically more complex, process: sequential composition and concurrent composition. Particularly, the output of the latter operation is a process in which any event not shared by both operands can occur whenever the operand that admits the event can engage in it, whereas any event shared by both operands can occur just in case both can engage in it.

This paper formalizes Hoare's definition of concurrent composition and proves, in the general case of a possibly intransitive policy, that CSP noninterference security is conserved under this operation. This result, along with the previous analogous one concerning sequential composition, enables the construction of more and more complex processes enforcing noninterference security by composing, sequentially or concurrently, simpler secure processes, whose security can in turn be proven using either the definition of security, or unwinding theorems.

[ROBDD] title = Algorithms for Reduced Ordered Binary Decision Diagrams author = Julius Michaelis , Maximilian Haslbeck , Peter Lammich , Lars Hupel date = 2016-04-27 topic = Computer science/Algorithms, Computer science/Data structures abstract = We present a verified and executable implementation of ROBDDs in Isabelle/HOL. Our implementation relates pointer-based computation in the Heap monad to operations on an abstract definition of boolean functions. Internally, we implemented the if-then-else combinator in a recursive fashion, following the Shannon decomposition of the argument functions. The implementation mixes and adapts known techniques and is built with efficiency in mind. notify = bdd@liftm.de, haslbecm@in.tum.de [No_FTL_observers] title = No Faster-Than-Light Observers author = Mike Stannett , István Németi date = 2016-04-28 topic = Mathematics/Physics abstract = We provide a formal proof within First Order Relativity Theory that no observer can travel faster than the speed of light. Originally reported in Stannett & Németi (2014) "Using Isabelle/HOL to verify first-order relativity theory", Journal of Automated Reasoning 52(4), pp. 361-378. notify = m.stannett@sheffield.ac.uk [Groebner_Bases] title = Gröbner Bases Theory author = Fabian Immler , Alexander Maletzky date = 2016-05-02 topic = Mathematics/Algebra, Computer science/Algorithms/Mathematical abstract = This formalization is concerned with the theory of Gröbner bases in (commutative) multivariate polynomial rings over fields, originally developed by Buchberger in his 1965 PhD thesis. Apart from the statement and proof of the main theorem of the theory, the formalization also implements Buchberger's algorithm for actually computing Gröbner bases as a tail-recursive function, thus allowing to effectively decide ideal membership in finitely generated polynomial ideals. Furthermore, all functions can be executed on a concrete representation of multivariate polynomials as association lists. extra-history = Change history: [2019-04-18]: Specialized Gröbner bases to less abstract representation of polynomials, where power-products are represented as polynomial mappings.
notify = alexander.maletzky@risc.jku.at [Nullstellensatz] title = Hilbert's Nullstellensatz author = Alexander Maletzky topic = Mathematics/Algebra, Mathematics/Geometry date = 2019-06-16 notify = alexander.maletzky@risc-software.at abstract = This entry formalizes Hilbert's Nullstellensatz, an important theorem in algebraic geometry that can be viewed as the generalization of the Fundamental Theorem of Algebra to multivariate polynomials: If a set of (multivariate) polynomials over an algebraically closed field has no common zero, then the ideal it generates is the entire polynomial ring. The formalization proves several equivalent versions of this celebrated theorem: the weak Nullstellensatz, the strong Nullstellensatz (connecting algebraic varieties and radical ideals), and the field-theoretic Nullstellensatz. The formalization follows Chapter 4.1. of Ideals, Varieties, and Algorithms by Cox, Little and O'Shea. [Bell_Numbers_Spivey] title = Spivey's Generalized Recurrence for Bell Numbers author = Lukas Bulwahn date = 2016-05-04 topic = Mathematics/Combinatorics abstract = This entry defines the Bell numbers as the cardinality of set partitions for a carrier set of given size, and derives Spivey's generalized recurrence relation for Bell numbers following his elegant and intuitive combinatorial proof.

As the set construction for the combinatorial proof requires construction of three intermediate structures, the main difficulty of the formalization is handling the overall combinatorial argument in a structured way. The introduced proof structure allows us to compose the combinatorial argument from its subparts, and supports to keep track how the detailed proof steps are related to the overall argument. To obtain this structure, this entry uses set monad notation for the set construction's definition, introduces suitable predicates and rules, and follows a repeating structure in its Isar proof. notify = lukas.bulwahn@gmail.com [Randomised_Social_Choice] title = Randomised Social Choice Theory author = Manuel Eberl date = 2016-05-05 topic = Mathematics/Games and economics abstract = This work contains a formalisation of basic Randomised Social Choice, including Stochastic Dominance and Social Decision Schemes (SDSs) along with some of their most important properties (Anonymity, Neutrality, ex-post- and SD-Efficiency, SD-Strategy-Proofness) and two particular SDSs – Random Dictatorship and Random Serial Dictatorship (with proofs of the properties that they satisfy). Many important properties of these concepts are also proven – such as the two equivalent characterisations of Stochastic Dominance and the fact that SD-efficiency of a lottery only depends on the support. The entry also provides convenient commands to define Preference Profiles, prove their well-formedness, and automatically derive restrictions that sufficiently nice SDSs need to satisfy on the defined profiles. Currently, the formalisation focuses on weak preferences and Stochastic Dominance, but it should be easy to extend it to other domains – such as strict preferences – or other lottery extensions – such as Bilinear Dominance or Pairwise Comparison. notify = eberlm@in.tum.de [SDS_Impossibility] title = The Incompatibility of SD-Efficiency and SD-Strategy-Proofness author = Manuel Eberl date = 2016-05-04 topic = Mathematics/Games and economics abstract = This formalisation contains the proof that there is no anonymous and neutral Social Decision Scheme for at least four voters and alternatives that fulfils both SD-Efficiency and SD-Strategy- Proofness. The proof is a fully structured and quasi-human-redable one. It was derived from the (unstructured) SMT proof of the case for exactly four voters and alternatives by Brandl et al. Their proof relies on an unverified translation of the original problem to SMT, and the proof that lifts the argument for exactly four voters and alternatives to the general case is also not machine-checked. In this Isabelle proof, on the other hand, all of these steps are fully proven and machine-checked. This is particularly important seeing as a previously published informal proof of a weaker statement contained a mistake in precisely this lifting step. notify = eberlm@in.tum.de [Median_Of_Medians_Selection] title = The Median-of-Medians Selection Algorithm author = Manuel Eberl topic = Computer science/Algorithms date = 2017-12-21 notify = eberlm@in.tum.de abstract =

This entry provides an executable functional implementation of the Median-of-Medians algorithm for selecting the k-th smallest element of an unsorted list deterministically in linear time. The size bounds for the recursive call that lead to the linear upper bound on the run-time of the algorithm are also proven.

[Mason_Stothers] title = The Mason–Stothers Theorem author = Manuel Eberl topic = Mathematics/Algebra date = 2017-12-21 notify = eberlm@in.tum.de abstract =

This article provides a formalisation of Snyder’s simple and elegant proof of the Mason–Stothers theorem, which is the polynomial analogue of the famous abc Conjecture for integers. Remarkably, Snyder found this very elegant proof when he was still a high-school student.

In short, the statement of the theorem is that three non-zero coprime polynomials A, B, C over a field which sum to 0 and do not all have vanishing derivatives fulfil max{deg(A), deg(B), deg(C)} < deg(rad(ABC)) where the rad(P) denotes the radical of P, i. e. the product of all unique irreducible factors of P.

This theorem also implies a kind of polynomial analogue of Fermat’s Last Theorem for polynomials: except for trivial cases, An + Bn + Cn = 0 implies n ≤ 2 for coprime polynomials A, B, C over a field.

[FLP] title = A Constructive Proof for FLP author = Benjamin Bisping , Paul-David Brodmann , Tim Jungnickel , Christina Rickmann , Henning Seidler , Anke Stüber , Arno Wilhelm-Weidner , Kirstin Peters , Uwe Nestmann date = 2016-05-18 topic = Computer science/Concurrency abstract = The impossibility of distributed consensus with one faulty process is a result with important consequences for real world distributed systems e.g., commits in replicated databases. Since proofs are not immune to faults and even plausible proofs with a profound formalism can conclude wrong results, we validate the fundamental result named FLP after Fischer, Lynch and Paterson. We present a formalization of distributed systems and the aforementioned consensus problem. Our proof is based on Hagen Völzer's paper "A constructive proof for FLP". In addition to the enhanced confidence in the validity of Völzer's proof, we contribute the missing gaps to show the correctness in Isabelle/HOL. We clarify the proof details and even prove fairness of the infinite execution that contradicts consensus. Our Isabelle formalization can also be reused for further proofs of properties of distributed systems. notify = henning.seidler@mailbox.tu-berlin.de [IMAP-CRDT] title = The IMAP CmRDT author = Tim Jungnickel , Lennart Oldenburg <>, Matthias Loibl <> topic = Computer science/Algorithms/Distributed, Computer science/Data structures date = 2017-11-09 notify = tim.jungnickel@tu-berlin.de abstract = We provide our Isabelle/HOL formalization of a Conflict-free Replicated Datatype for Internet Message Access Protocol commands. We show that Strong Eventual Consistency (SEC) is guaranteed by proving the commutativity of concurrent operations. We base our formalization on the recently proposed "framework for establishing Strong Eventual Consistency for Conflict-free Replicated Datatypes" (AFP.CRDT) from Gomes et al. Hence, we provide an additional example of how the recently proposed framework can be used to design and prove CRDTs. [Incredible_Proof_Machine] title = The meta theory of the Incredible Proof Machine author = Joachim Breitner , Denis Lohner date = 2016-05-20 topic = Logic/Proof theory abstract = The Incredible Proof Machine is an interactive visual theorem prover which represents proofs as port graphs. We model this proof representation in Isabelle, and prove that it is just as powerful as natural deduction. notify = mail@joachim-breitner.de [Word_Lib] title = Finite Machine Word Library author = Joel Beeren<>, Matthew Fernandez<>, Xin Gao<>, Gerwin Klein , Rafal Kolanski<>, Japheth Lim<>, Corey Lewis<>, Daniel Matichuk<>, Thomas Sewell<> notify = kleing@unsw.edu.au date = 2016-06-09 topic = Computer science/Data structures abstract = This entry contains an extension to the Isabelle library for fixed-width machine words. In particular, the entry adds quickcheck setup for words, printing as hexadecimals, additional operations, reasoning about alignment, signed words, enumerations of words, normalisation of word numerals, and an extensive library of properties about generic fixed-width words, as well as an instantiation of many of these to the commonly used 32 and 64-bit bases. [Catalan_Numbers] title = Catalan Numbers author = Manuel Eberl notify = eberlm@in.tum.de date = 2016-06-21 topic = Mathematics/Combinatorics abstract =

In this work, we define the Catalan numbers Cn and prove several equivalent definitions (including some closed-form formulae). We also show one of their applications (counting the number of binary trees of size n), prove the asymptotic growth approximation Cn ∼ 4n / (√π · n1.5), and provide reasonably efficient executable code to compute them.

The derivation of the closed-form formulae uses algebraic manipulations of the ordinary generating function of the Catalan numbers, and the asymptotic approximation is then done using generalised binomial coefficients and the Gamma function. Thanks to these highly non-elementary mathematical tools, the proofs are very short and simple.

[Fisher_Yates] title = Fisher–Yates shuffle author = Manuel Eberl notify = eberlm@in.tum.de date = 2016-09-30 topic = Computer science/Algorithms abstract =

This work defines and proves the correctness of the Fisher–Yates algorithm for shuffling – i.e. producing a random permutation – of a list. The algorithm proceeds by traversing the list and in each step swapping the current element with a random element from the remaining list.

[Bertrands_Postulate] title = Bertrand's postulate author = Julian Biendarra<>, Manuel Eberl contributors = Lawrence C. Paulson topic = Mathematics/Number theory date = 2017-01-17 notify = eberlm@in.tum.de abstract =

Bertrand's postulate is an early result on the distribution of prime numbers: For every positive integer n, there exists a prime number that lies strictly between n and 2n. The proof is ported from John Harrison's formalisation in HOL Light. It proceeds by first showing that the property is true for all n greater than or equal to 600 and then showing that it also holds for all n below 600 by case distinction.

[Rewriting_Z] title = The Z Property author = Bertram Felgenhauer<>, Julian Nagele<>, Vincent van Oostrom<>, Christian Sternagel notify = bertram.felgenhauer@uibk.ac.at, julian.nagele@uibk.ac.at, c.sternagel@gmail.com date = 2016-06-30 topic = Logic/Rewriting abstract = We formalize the Z property introduced by Dehornoy and van Oostrom. First we show that for any abstract rewrite system, Z implies confluence. Then we give two examples of proofs using Z: confluence of lambda-calculus with respect to beta-reduction and confluence of combinatory logic. [Resolution_FOL] title = The Resolution Calculus for First-Order Logic author = Anders Schlichtkrull notify = andschl@dtu.dk date = 2016-06-30 topic = Logic/General logic/Mechanization of proofs abstract = This theory is a formalization of the resolution calculus for first-order logic. It is proven sound and complete. The soundness proof uses the substitution lemma, which shows a correspondence between substitutions and updates to an environment. The completeness proof uses semantic trees, i.e. trees whose paths are partial Herbrand interpretations. It employs Herbrand's theorem in a formulation which states that an unsatisfiable set of clauses has a finite closed semantic tree. It also uses the lifting lemma which lifts resolution derivation steps from the ground world up to the first-order world. The theory is presented in a paper in the Journal of Automated Reasoning [Sch18] which extends a paper presented at the International Conference on Interactive Theorem Proving [Sch16]. An earlier version was presented in an MSc thesis [Sch15]. The formalization mostly follows textbooks by Ben-Ari [BA12], Chang and Lee [CL73], and Leitsch [Lei97]. The theory is part of the IsaFoL project [IsaFoL].

[Sch18] Anders Schlichtkrull. "Formalization of the Resolution Calculus for First-Order Logic". Journal of Automated Reasoning, 2018.
[Sch16] Anders Schlichtkrull. "Formalization of the Resolution Calculus for First-Order Logic". In: ITP 2016. Vol. 9807. LNCS. Springer, 2016.
[Sch15] Anders Schlichtkrull. "Formalization of Resolution Calculus in Isabelle". https://people.compute.dtu.dk/andschl/Thesis.pdf. MSc thesis. Technical University of Denmark, 2015.
[BA12] Mordechai Ben-Ari. Mathematical Logic for Computer Science. 3rd. Springer, 2012.
[CL73] Chin-Liang Chang and Richard Char-Tung Lee. Symbolic Logic and Mechanical Theorem Proving. 1st. Academic Press, Inc., 1973.
[Lei97] Alexander Leitsch. The Resolution Calculus. Texts in theoretical computer science. Springer, 1997.
[IsaFoL] IsaFoL authors. IsaFoL: Isabelle Formalization of Logic. https://bitbucket.org/jasmin_blanchette/isafol. extra-history = Change history: [2018-01-24]: added several new versions of the soundness and completeness theorems as described in the paper [Sch18].
[2018-03-20]: added a concrete instance of the unification and completeness theorems using the First-Order Terms AFP-entry from IsaFoR as described in the papers [Sch16] and [Sch18]. [Surprise_Paradox] title = Surprise Paradox author = Joachim Breitner notify = mail@joachim-breitner.de date = 2016-07-17 topic = Logic/Proof theory abstract = In 1964, Fitch showed that the paradox of the surprise hanging can be resolved by showing that the judge’s verdict is inconsistent. His formalization builds on Gödel’s coding of provability. In this theory, we reproduce his proof in Isabelle, building on Paulson’s formalisation of Gödel’s incompleteness theorems. [Ptolemys_Theorem] title = Ptolemy's Theorem author = Lukas Bulwahn notify = lukas.bulwahn@gmail.com date = 2016-08-07 topic = Mathematics/Geometry abstract = This entry provides an analytic proof to Ptolemy's Theorem using polar form transformation and trigonometric identities. In this formalization, we use ideas from John Harrison's HOL Light formalization and the proof sketch on the Wikipedia entry of Ptolemy's Theorem. This theorem is the 95th theorem of the Top 100 Theorems list. [Falling_Factorial_Sum] title = The Falling Factorial of a Sum author = Lukas Bulwahn topic = Mathematics/Combinatorics date = 2017-12-22 notify = lukas.bulwahn@gmail.com abstract = This entry shows that the falling factorial of a sum can be computed with an expression using binomial coefficients and the falling factorial of its summands. The entry provides three different proofs: a combinatorial proof, an induction proof and an algebraic proof using the Vandermonde identity. The three formalizations try to follow their informal presentations from a Mathematics Stack Exchange page as close as possible. The induction and algebraic formalization end up to be very close to their informal presentation, whereas the combinatorial proof first requires the introduction of list interleavings, and significant more detail than its informal presentation. [InfPathElimination] title = Infeasible Paths Elimination by Symbolic Execution Techniques: Proof of Correctness and Preservation of Paths author = Romain Aissat<>, Frederic Voisin<>, Burkhart Wolff notify = wolff@lri.fr date = 2016-08-18 topic = Computer science/Programming languages/Static analysis abstract = TRACER is a tool for verifying safety properties of sequential C programs. TRACER attempts at building a finite symbolic execution graph which over-approximates the set of all concrete reachable states and the set of feasible paths. We present an abstract framework for TRACER and similar CEGAR-like systems. The framework provides 1) a graph- transformation based method for reducing the feasible paths in control-flow graphs, 2) a model for symbolic execution, subsumption, predicate abstraction and invariant generation. In this framework we formally prove two key properties: correct construction of the symbolic states and preservation of feasible paths. The framework focuses on core operations, leaving to concrete prototypes to “fit in” heuristics for combining them. The accompanying paper (published in ITP 2016) can be found at https://www.lri.fr/∼wolff/papers/conf/2016-itp-InfPathsNSE.pdf. [Stirling_Formula] title = Stirling's formula author = Manuel Eberl notify = eberlm@in.tum.de date = 2016-09-01 topic = Mathematics/Analysis abstract =

This work contains a proof of Stirling's formula both for the factorial $n! \sim \sqrt{2\pi n} (n/e)^n$ on natural numbers and the real Gamma function $\Gamma(x)\sim \sqrt{2\pi/x} (x/e)^x$. The proof is based on work by Graham Jameson.

This is then extended to the full asymptotic expansion $$\log\Gamma(z) = \big(z - \tfrac{1}{2}\big)\log z - z + \tfrac{1}{2}\log(2\pi) + \sum_{k=1}^{n-1} \frac{B_{k+1}}{k(k+1)} z^{-k}\\ {} - \frac{1}{n} \int_0^\infty B_n([t])(t + z)^{-n}\,\text{d}t$$ uniformly for all complex $z\neq 0$ in the cone $\text{arg}(z)\leq \alpha$ for any $\alpha\in(0,\pi)$, with which the above asymptotic relation for Γ is also extended to complex arguments.

[Lp] title = Lp spaces author = Sebastien Gouezel notify = sebastien.gouezel@univ-rennes1.fr date = 2016-10-05 topic = Mathematics/Analysis abstract = Lp is the space of functions whose p-th power is integrable. It is one of the most fundamental Banach spaces that is used in analysis and probability. We develop a framework for function spaces, and then implement the Lp spaces in this framework using the existing integration theory in Isabelle/HOL. Our development contains most fundamental properties of Lp spaces, notably the Hölder and Minkowski inequalities, completeness of Lp, duality, stability under almost sure convergence, multiplication of functions in Lp and Lq, stability under conditional expectation. [Berlekamp_Zassenhaus] title = The Factorization Algorithm of Berlekamp and Zassenhaus author = Jose Divasón , Sebastiaan Joosten , René Thiemann , Akihisa Yamada notify = rene.thiemann@uibk.ac.at date = 2016-10-14 topic = Mathematics/Algebra abstract =

We formalize the Berlekamp-Zassenhaus algorithm for factoring square-free integer polynomials in Isabelle/HOL. We further adapt an existing formalization of Yun’s square-free factorization algorithm to integer polynomials, and thus provide an efficient and certified factorization algorithm for arbitrary univariate polynomials.

The algorithm first performs a factorization in the prime field GF(p) and then performs computations in the integer ring modulo p^k, where both p and k are determined at runtime. Since a natural modeling of these structures via dependent types is not possible in Isabelle/HOL, we formalize the whole algorithm using Isabelle’s recent addition of local type definitions.

Through experiments we verify that our algorithm factors polynomials of degree 100 within seconds.

[Allen_Calculus] title = Allen's Interval Calculus author = Fadoua Ghourabi <> notify = fadouaghourabi@gmail.com date = 2016-09-29 topic = Logic/General logic/Temporal logic, Mathematics/Order abstract = Allen’s interval calculus is a qualitative temporal representation of time events. Allen introduced 13 binary relations that describe all the possible arrangements between two events, i.e. intervals with non-zero finite length. The compositions are pertinent to reasoning about knowledge of time. In particular, a consistency problem of relation constraints is commonly solved with a guideline from these compositions. We formalize the relations together with an axiomatic system. We proof the validity of the 169 compositions of these relations. We also define nests as the sets of intervals that share a meeting point. We prove that nests give the ordering properties of points without introducing a new datatype for points. [1] J.F. Allen. Maintaining Knowledge about Temporal Intervals. In Commun. ACM, volume 26, pages 832–843, 1983. [2] J. F. Allen and P. J. Hayes. A Common-sense Theory of Time. In Proceedings of the 9th International Joint Conference on Artificial Intelligence (IJCAI’85), pages 528–531, 1985. [Source_Coding_Theorem] title = Source Coding Theorem author = Quentin Hibon , Lawrence C. Paulson notify = qh225@cl.cam.ac.uk date = 2016-10-19 topic = Mathematics/Probability theory abstract = This document contains a proof of the necessary condition on the code rate of a source code, namely that this code rate is bounded by the entropy of the source. This represents one half of Shannon's source coding theorem, which is itself an equivalence. [Buffons_Needle] title = Buffon's Needle Problem author = Manuel Eberl topic = Mathematics/Probability theory, Mathematics/Geometry date = 2017-06-06 notify = eberlm@in.tum.de abstract = In the 18th century, Georges-Louis Leclerc, Comte de Buffon posed and later solved the following problem, which is often called the first problem ever solved in geometric probability: Given a floor divided into vertical strips of the same width, what is the probability that a needle thrown onto the floor randomly will cross two strips? This entry formally defines the problem in the case where the needle's position is chosen uniformly at random in a single strip around the origin (which is equivalent to larger arrangements due to symmetry). It then provides proofs of the simple solution in the case where the needle's length is no greater than the width of the strips and the more complicated solution in the opposite case. [SPARCv8] title = A formal model for the SPARCv8 ISA and a proof of non-interference for the LEON3 processor author = Zhe Hou , David Sanan , Alwen Tiu , Yang Liu notify = zhe.hou@ntu.edu.sg, sanan@ntu.edu.sg date = 2016-10-19 topic = Computer science/Security, Computer science/Hardware abstract = We formalise the SPARCv8 instruction set architecture (ISA) which is used in processors such as LEON3. Our formalisation can be specialised to any SPARCv8 CPU, here we use LEON3 as a running example. Our model covers the operational semantics for all the instructions in the integer unit of the SPARCv8 architecture and it supports Isabelle code export, which effectively turns the Isabelle model into a SPARCv8 CPU simulator. We prove the language-based non-interference property for the LEON3 processor. Our model is based on deterministic monad, which is a modified version of the non-deterministic monad from NICTA/l4v. [Separata] title = Separata: Isabelle tactics for Separation Algebra author = Zhe Hou , David Sanan , Alwen Tiu , Rajeev Gore , Ranald Clouston notify = zhe.hou@ntu.edu.sg date = 2016-11-16 topic = Computer science/Programming languages/Logics, Tools abstract = We bring the labelled sequent calculus $LS_{PASL}$ for propositional abstract separation logic to Isabelle. The tactics given here are directly applied on an extension of the Separation Algebra in the AFP. In addition to the cancellative separation algebra, we further consider some useful properties in the heap model of separation logic, such as indivisible unit, disjointness, and cross-split. The tactics are essentially a proof search procedure for the calculus $LS_{PASL}$. We wrap the tactics in an Isabelle method called separata, and give a few examples of separation logic formulae which are provable by separata. [LOFT] title = LOFT — Verified Migration of Linux Firewalls to SDN author = Julius Michaelis , Cornelius Diekmann notify = isabelleopenflow@liftm.de date = 2016-10-21 topic = Computer science/Networks abstract = We present LOFT — Linux firewall OpenFlow Translator, a system that transforms the main routing table and FORWARD chain of iptables of a Linux-based firewall into a set of static OpenFlow rules. Our implementation is verified against a model of a simplified Linux-based router and we can directly show how much of the original functionality is preserved. [Stable_Matching] title = Stable Matching author = Peter Gammie notify = peteg42@gmail.com date = 2016-10-24 topic = Mathematics/Games and economics abstract = We mechanize proofs of several results from the matching with contracts literature, which generalize those of the classical two-sided matching scenarios that go by the name of stable marriage. Our focus is on game theoretic issues. Along the way we develop executable algorithms for computing optimal stable matches. [Modal_Logics_for_NTS] title = Modal Logics for Nominal Transition Systems author = Tjark Weber , Lars-Henrik Eriksson , Joachim Parrow , Johannes Borgström , Ramunas Gutkovas notify = tjark.weber@it.uu.se date = 2016-10-25 topic = Computer science/Concurrency/Process calculi, Logic/General logic/Modal logic abstract = We formalize a uniform semantic substrate for a wide variety of process calculi where states and action labels can be from arbitrary nominal sets. A Hennessy-Milner logic for these systems is defined, and proved adequate for bisimulation equivalence. A main novelty is the construction of an infinitary nominal data type to model formulas with (finitely supported) infinite conjunctions and actions that may contain binding names. The logic is generalized to treat different bisimulation variants such as early, late and open in a systematic way. extra-history = Change history: [2017-01-29]: Formalization of weak bisimilarity added (revision c87cc2057d9c) [Abs_Int_ITP2012] title = Abstract Interpretation of Annotated Commands author = Tobias Nipkow notify = nipkow@in.tum.de date = 2016-11-23 topic = Computer science/Programming languages/Static analysis abstract = This is the Isabelle formalization of the material decribed in the eponymous ITP 2012 paper. It develops a generic abstract interpreter for a while-language, including widening and narrowing. The collecting semantics and the abstract interpreter operate on annotated commands: the program is represented as a syntax tree with the semantic information directly embedded, without auxiliary labels. The aim of the formalization is simplicity, not efficiency or precision. This is motivated by the inclusion of the material in a theorem prover based course on semantics. A similar (but more polished) development is covered in the book Concrete Semantics. [Complx] title = COMPLX: A Verification Framework for Concurrent Imperative Programs author = Sidney Amani<>, June Andronick<>, Maksym Bortin<>, Corey Lewis<>, Christine Rizkallah<>, Joseph Tuong<> notify = sidney.amani@data61.csiro.au, corey.lewis@data61.csiro.au date = 2016-11-29 topic = Computer science/Programming languages/Logics, Computer science/Programming languages/Language definitions abstract = We propose a concurrency reasoning framework for imperative programs, based on the Owicki-Gries (OG) foundational shared-variable concurrency method. Our framework combines the approaches of Hoare-Parallel, a formalisation of OG in Isabelle/HOL for a simple while-language, and Simpl, a generic imperative language embedded in Isabelle/HOL, allowing formal reasoning on C programs. We define the Complx language, extending the syntax and semantics of Simpl with support for parallel composition and synchronisation. We additionally define an OG logic, which we prove sound w.r.t. the semantics, and a verification condition generator, both supporting involved low-level imperative constructs such as function calls and abrupt termination. We illustrate our framework on an example that features exceptions, guards and function calls. We aim to then target concurrent operating systems, such as the interruptible eChronos embedded operating system for which we already have a model-level OG proof using Hoare-Parallel. extra-history = Change history: [2017-01-13]: Improve VCG for nested parallels and sequential sections (revision 30739dbc3dcb) [Paraconsistency] title = Paraconsistency author = Anders Schlichtkrull , Jørgen Villadsen topic = Logic/General logic/Paraconsistent logics date = 2016-12-07 notify = andschl@dtu.dk, jovi@dtu.dk abstract = Paraconsistency is about handling inconsistency in a coherent way. In classical and intuitionistic logic everything follows from an inconsistent theory. A paraconsistent logic avoids the explosion. Quite a few applications in computer science and engineering are discussed in the Intelligent Systems Reference Library Volume 110: Towards Paraconsistent Engineering (Springer 2016). We formalize a paraconsistent many-valued logic that we motivated and described in a special issue on logical approaches to paraconsistency (Journal of Applied Non-Classical Logics 2005). We limit ourselves to the propositional fragment of the higher-order logic. The logic is based on so-called key equalities and has a countably infinite number of truth values. We prove theorems in the logic using the definition of validity. We verify truth tables and also counterexamples for non-theorems. We prove meta-theorems about the logic and finally we investigate a case study. [Proof_Strategy_Language] title = Proof Strategy Language author = Yutaka Nagashima<> topic = Tools date = 2016-12-20 notify = Yutaka.Nagashima@data61.csiro.au abstract = Isabelle includes various automatic tools for finding proofs under certain conditions. However, for each conjecture, knowing which automation to use, and how to tweak its parameters, is currently labour intensive. We have developed a language, PSL, designed to capture high level proof strategies. PSL offloads the construction of human-readable fast-to-replay proof scripts to automatic search, making use of search-time information about each conjecture. Our preliminary evaluations show that PSL reduces the labour cost of interactive theorem proving. This submission contains the implementation of PSL and an example theory file, Example.thy, showing how to write poof strategies in PSL. [Concurrent_Ref_Alg] title = Concurrent Refinement Algebra and Rely Quotients author = Julian Fell , Ian J. Hayes , Andrius Velykis topic = Computer science/Concurrency date = 2016-12-30 notify = Ian.Hayes@itee.uq.edu.au abstract = The concurrent refinement algebra developed here is designed to provide a foundation for rely/guarantee reasoning about concurrent programs. The algebra builds on a complete lattice of commands by providing sequential composition, parallel composition and a novel weak conjunction operator. The weak conjunction operator coincides with the lattice supremum providing its arguments are non-aborting, but aborts if either of its arguments do. Weak conjunction provides an abstract version of a guarantee condition as a guarantee process. We distinguish between models that distribute sequential composition over non-deterministic choice from the left (referred to as being conjunctive in the refinement calculus literature) and those that don't. Least and greatest fixed points of monotone functions are provided to allow recursion and iteration operators to be added to the language. Additional iteration laws are available for conjunctive models. The rely quotient of processes c and i is the process that, if executed in parallel with i implements c. It represents an abstract version of a rely condition generalised to a process. [FOL_Harrison] title = First-Order Logic According to Harrison author = Alexander Birch Jensen , Anders Schlichtkrull , Jørgen Villadsen topic = Logic/General logic/Mechanization of proofs date = 2017-01-01 notify = aleje@dtu.dk, andschl@dtu.dk, jovi@dtu.dk abstract =

We present a certified declarative first-order prover with equality based on John Harrison's Handbook of Practical Logic and Automated Reasoning, Cambridge University Press, 2009. ML code reflection is used such that the entire prover can be executed within Isabelle as a very simple interactive proof assistant. As examples we consider Pelletier's problems 1-46.

Reference: Programming and Verifying a Declarative First-Order Prover in Isabelle/HOL. Alexander Birch Jensen, John Bruntse Larsen, Anders Schlichtkrull & Jørgen Villadsen. AI Communications 31:281-299 2018. https://content.iospress.com/articles/ai-communications/aic764

See also: Students' Proof Assistant (SPA). https://github.com/logic-tools/spa

extra-history = Change history: [2018-07-21]: Proof of Pelletier's problem 34 (Andrews's Challenge) thanks to Asta Halkjær From. [Bernoulli] title = Bernoulli Numbers author = Lukas Bulwahn, Manuel Eberl topic = Mathematics/Analysis, Mathematics/Number theory date = 2017-01-24 notify = eberlm@in.tum.de abstract =

Bernoulli numbers were first discovered in the closed-form expansion of the sum 1m + 2m + … + nm for a fixed m and appear in many other places. This entry provides three different definitions for them: a recursive one, an explicit one, and one through their exponential generating function.

In addition, we prove some basic facts, e.g. their relation to sums of powers of integers and that all odd Bernoulli numbers except the first are zero, and some advanced facts like their relationship to the Riemann zeta function on positive even integers.

We also prove the correctness of the Akiyama–Tanigawa algorithm for computing Bernoulli numbers with reasonable efficiency, and we define the periodic Bernoulli polynomials (which appear e.g. in the Euler–MacLaurin summation formula and the expansion of the log-Gamma function) and prove their basic properties.

[Stone_Relation_Algebras] title = Stone Relation Algebras author = Walter Guttmann topic = Mathematics/Algebra date = 2017-02-07 notify = walter.guttmann@canterbury.ac.nz abstract = We develop Stone relation algebras, which generalise relation algebras by replacing the underlying Boolean algebra structure with a Stone algebra. We show that finite matrices over extended real numbers form an instance. As a consequence, relation-algebraic concepts and methods can be used for reasoning about weighted graphs. We also develop a fixpoint calculus and apply it to compare different definitions of reflexive-transitive closures in semirings. [Stone_Kleene_Relation_Algebras] title = Stone-Kleene Relation Algebras author = Walter Guttmann topic = Mathematics/Algebra date = 2017-07-06 notify = walter.guttmann@canterbury.ac.nz abstract = We develop Stone-Kleene relation algebras, which expand Stone relation algebras with a Kleene star operation to describe reachability in weighted graphs. Many properties of the Kleene star arise as a special case of a more general theory of iteration based on Conway semirings extended by simulation axioms. This includes several theorems representing complex program transformations. We formally prove the correctness of Conway's automata-based construction of the Kleene star of a matrix. We prove numerous results useful for reasoning about weighted graphs. [Abstract_Soundness] title = Abstract Soundness author = Jasmin Christian Blanchette , Andrei Popescu , Dmitriy Traytel topic = Logic/Proof theory date = 2017-02-10 notify = jasmin.blanchette@gmail.com abstract = A formalized coinductive account of the abstract development of Brotherston, Gorogiannis, and Petersen [APLAS 2012], in a slightly more general form since we work with arbitrary infinite proofs, which may be acyclic. This work is described in detail in an article by the authors, published in 2017 in the Journal of Automated Reasoning. The abstract proof can be instantiated for various formalisms, including first-order logic with inductive predicates. [Differential_Dynamic_Logic] title = Differential Dynamic Logic author = Brandon Bohrer topic = Logic/General logic/Modal logic, Computer science/Programming languages/Logics date = 2017-02-13 notify = bbohrer@cs.cmu.edu abstract = We formalize differential dynamic logic, a logic for proving properties of hybrid systems. The proof calculus in this formalization is based on the uniform substitution principle. We show it is sound with respect to our denotational semantics, which provides increased confidence in the correctness of the KeYmaera X theorem prover based on this calculus. As an application, we include a proof term checker embedded in Isabelle/HOL with several example proofs. Published in: Brandon Bohrer, Vincent Rahli, Ivana Vukotic, Marcus Völp, André Platzer: Formally verified differential dynamic logic. CPP 2017. [Elliptic_Curves_Group_Law] title = The Group Law for Elliptic Curves author = Stefan Berghofer topic = Computer science/Security/Cryptography date = 2017-02-28 notify = berghofe@in.tum.de abstract = We prove the group law for elliptic curves in Weierstrass form over fields of characteristic greater than 2. In addition to affine coordinates, we also formalize projective coordinates, which allow for more efficient computations. By specializing the abstract formalization to prime fields, we can apply the curve operations to parameters used in standard security protocols. [Example-Submission] title = Example Submission author = Gerwin Klein topic = Mathematics/Analysis, Mathematics/Number theory date = 2004-02-25 notify = kleing@cse.unsw.edu.au abstract =

This is an example submission to the Archive of Formal Proofs. It shows submission requirements and explains the structure of a simple typical submission.

Note that you can use HTML tags and LaTeX formulae like $\sum_{n=1}^\infty \frac{1}{n^2} = \frac{\pi^2}{6}$ in the abstract. Display formulae like $$ \int_0^1 x^{-x}\,\text{d}x = \sum_{n=1}^\infty n^{-n}$$ are also possible. Please read the submission guidelines before using this.

extra-no-index = no-index: true [CRDT] title = A framework for establishing Strong Eventual Consistency for Conflict-free Replicated Datatypes author = Victor B. F. Gomes , Martin Kleppmann, Dominic P. Mulligan, Alastair R. Beresford topic = Computer science/Algorithms/Distributed, Computer science/Data structures date = 2017-07-07 notify = vb358@cam.ac.uk, dominic.p.mulligan@googlemail.com abstract = In this work, we focus on the correctness of Conflict-free Replicated Data Types (CRDTs), a class of algorithm that provides strong eventual consistency guarantees for replicated data. We develop a modular and reusable framework for verifying the correctness of CRDT algorithms. We avoid correctness issues that have dogged previous mechanised proofs in this area by including a network model in our formalisation, and proving that our theorems hold in all possible network behaviours. Our axiomatic network model is a standard abstraction that accurately reflects the behaviour of real-world computer networks. Moreover, we identify an abstract convergence theorem, a property of order relations, which provides a formal definition of strong eventual consistency. We then obtain the first machine-checked correctness theorems for three concrete CRDTs: the Replicated Growable Array, the Observed-Remove Set, and an Increment-Decrement Counter. [HOLCF-Prelude] title = HOLCF-Prelude author = Joachim Breitner, Brian Huffman<>, Neil Mitchell<>, Christian Sternagel topic = Computer science/Functional programming date = 2017-07-15 notify = c.sternagel@gmail.com, joachim@cis.upenn.edu, hupel@in.tum.de abstract = The Isabelle/HOLCF-Prelude is a formalization of a large part of Haskell's standard prelude in Isabelle/HOLCF. We use it to prove the correctness of the Eratosthenes' Sieve, in its self-referential implementation commonly used to showcase Haskell's laziness; prove correctness of GHC's "fold/build" rule and related rewrite rules; and certify a number of hints suggested by HLint. [Decl_Sem_Fun_PL] title = Declarative Semantics for Functional Languages author = Jeremy Siek topic = Computer science/Programming languages date = 2017-07-21 notify = jsiek@indiana.edu abstract = We present a semantics for an applied call-by-value lambda-calculus that is compositional, extensional, and elementary. We present four different views of the semantics: 1) as a relational (big-step) semantics that is not operational but instead declarative, 2) as a denotational semantics that does not use domain theory, 3) as a non-deterministic interpreter, and 4) as a variant of the intersection type systems of the Torino group. We prove that the semantics is correct by showing that it is sound and complete with respect to operational semantics on programs and that is sound with respect to contextual equivalence. We have not yet investigated whether it is fully abstract. We demonstrate that this approach to semantics is useful with three case studies. First, we use the semantics to prove correctness of a compiler optimization that inlines function application. Second, we adapt the semantics to the polymorphic lambda-calculus extended with general recursion and prove semantic type soundness. Third, we adapt the semantics to the call-by-value lambda-calculus with mutable references.
The paper that accompanies these Isabelle theories is available on arXiv. [DynamicArchitectures] title = Dynamic Architectures author = Diego Marmsoler topic = Computer science/System description languages date = 2017-07-28 notify = diego.marmsoler@tum.de abstract = The architecture of a system describes the system's overall organization into components and connections between those components. With the emergence of mobile computing, dynamic architectures have become increasingly important. In such architectures, components may appear or disappear, and connections may change over time. In the following we mechanize a theory of dynamic architectures and verify the soundness of a corresponding calculus. Therefore, we first formalize the notion of configuration traces as a model for dynamic architectures. Then, the behavior of single components is formalized in terms of behavior traces and an operator is introduced and studied to extract the behavior of a single component out of a given configuration trace. Then, behavior trace assertions are introduced as a temporal specification technique to specify behavior of components. Reasoning about component behavior in a dynamic context is formalized in terms of a calculus for dynamic architectures. Finally, the soundness of the calculus is verified by introducing an alternative interpretation for behavior trace assertions over configuration traces and proving the rules of the calculus. Since projection may lead to finite as well as infinite behavior traces, they are formalized in terms of coinductive lists. Thus, our theory is based on Lochbihler's formalization of coinductive lists. The theory may be applied to verify properties for dynamic architectures. extra-history = Change history: [2018-06-07]: adding logical operators to specify configuration traces (revision 09178f08f050)
[Stewart_Apollonius] title = Stewart's Theorem and Apollonius' Theorem author = Lukas Bulwahn topic = Mathematics/Geometry date = 2017-07-31 notify = lukas.bulwahn@gmail.com abstract = This entry formalizes the two geometric theorems, Stewart's and Apollonius' theorem. Stewart's Theorem relates the length of a triangle's cevian to the lengths of the triangle's two sides. Apollonius' Theorem is a specialisation of Stewart's theorem, restricting the cevian to be the median. The proof applies the law of cosines, some basic geometric facts about triangles and then simply transforms the terms algebraically to yield the conjectured relation. The formalization in Isabelle can closely follow the informal proofs described in the Wikipedia articles of those two theorems. [LambdaMu] title = The LambdaMu-calculus author = Cristina Matache , Victor B. F. Gomes , Dominic P. Mulligan topic = Computer science/Programming languages/Lambda calculi, Logic/General logic/Lambda calculus date = 2017-08-16 notify = victorborgesfg@gmail.com, dominic.p.mulligan@googlemail.com abstract = The propositions-as-types correspondence is ordinarily presented as linking the metatheory of typed λ-calculi and the proof theory of intuitionistic logic. Griffin observed that this correspondence could be extended to classical logic through the use of control operators. This observation set off a flurry of further research, leading to the development of Parigots λμ-calculus. In this work, we formalise λμ- calculus in Isabelle/HOL and prove several metatheoretical properties such as type preservation and progress. [Orbit_Stabiliser] title = Orbit-Stabiliser Theorem with Application to Rotational Symmetries author = Jonas Rädle topic = Mathematics/Algebra date = 2017-08-20 notify = jonas.raedle@tum.de abstract = The Orbit-Stabiliser theorem is a basic result in the algebra of groups that factors the order of a group into the sizes of its orbits and stabilisers. We formalize the notion of a group action and the related concepts of orbits and stabilisers. This allows us to prove the orbit-stabiliser theorem. In the second part of this work, we formalize the tetrahedral group and use the orbit-stabiliser theorem to prove that there are twelve (orientation-preserving) rotations of the tetrahedron. [PLM] title = Representation and Partial Automation of the Principia Logico-Metaphysica in Isabelle/HOL author = Daniel Kirchner topic = Logic/Philosophical aspects date = 2017-09-17 notify = daniel@ekpyron.org abstract =

We present an embedding of the second-order fragment of the Theory of Abstract Objects as described in Edward Zalta's upcoming work Principia Logico-Metaphysica (PLM) in the automated reasoning framework Isabelle/HOL. The Theory of Abstract Objects is a metaphysical theory that reifies property patterns, as they for example occur in the abstract reasoning of mathematics, as abstract objects and provides an axiomatic framework that allows to reason about these objects. It thereby serves as a fundamental metaphysical theory that can be used to axiomatize and describe a wide range of philosophical objects, such as Platonic forms or Leibniz' concepts, and has the ambition to function as a foundational theory of mathematics. The target theory of our embedding as described in chapters 7-9 of PLM employs a modal relational type theory as logical foundation for which a representation in functional type theory is known to be challenging.

Nevertheless we arrive at a functioning representation of the theory in the functional logic of Isabelle/HOL based on a semantical representation of an Aczel-model of the theory. Based on this representation we construct an implementation of the deductive system of PLM which allows to automatically and interactively find and verify theorems of PLM.

Our work thereby supports the concept of shallow semantical embeddings of logical systems in HOL as a universal tool for logical reasoning as promoted by Christoph Benzmüller.

The most notable result of the presented work is the discovery of a previously unknown paradox in the formulation of the Theory of Abstract Objects. The embedding of the theory in Isabelle/HOL played a vital part in this discovery. Furthermore it was possible to immediately offer several options to modify the theory to guarantee its consistency. Thereby our work could provide a significant contribution to the development of a proper grounding for object theory.

[KD_Tree] title = Multidimensional Binary Search Trees author = Martin Rau<> topic = Computer science/Data structures date = 2019-05-30 notify = martin.rau@tum.de, mrtnrau@googlemail.com abstract = This entry provides a formalization of multidimensional binary trees, also known as k-d trees. It includes a balanced build algorithm as well as the nearest neighbor algorithm and the range search algorithm. It is based on the papers Multidimensional binary search trees used for associative searching and An Algorithm for Finding Best Matches in Logarithmic Expected Time. extra-history = Change history: [2020-15-04]: Change representation of k-dimensional points from 'list' to HOL-Analysis.Finite_Cartesian_Product 'vec'. Update proofs to incorporate HOL-Analysis 'dist' and 'cbox' primitives. [Closest_Pair_Points] title = Closest Pair of Points Algorithms author = Martin Rau , Tobias Nipkow topic = Computer science/Algorithms/Geometry date = 2020-01-13 notify = martin.rau@tum.de, nipkow@in.tum.de abstract = This entry provides two related verified divide-and-conquer algorithms solving the fundamental Closest Pair of Points problem in Computational Geometry. Functional correctness and the optimal running time of O(n log n) are proved. Executable code is generated which is empirically competitive with handwritten reference implementations. extra-history = Change history: [2020-14-04]: Incorporate Time_Monad of the AFP entry Root_Balanced_Tree. [Approximation_Algorithms] title = Verified Approximation Algorithms author = Robin Eßmann , Tobias Nipkow , Simon Robillard topic = Computer science/Algorithms/Approximation date = 2020-01-16 notify = nipkow@in.tum.de abstract = We present the first formal verification of approximation algorithms for NP-complete optimization problems: vertex cover, independent set, load balancing, and bin packing. The proofs correct incompletenesses in existing proofs and improve the approximation ratio in one case. [Diophantine_Eqns_Lin_Hom] title = Homogeneous Linear Diophantine Equations author = Florian Messner , Julian Parsert , Jonas Schöpf , Christian Sternagel topic = Computer science/Algorithms/Mathematical, Mathematics/Number theory, Tools license = LGPL date = 2017-10-14 notify = c.sternagel@gmail.com, julian.parsert@gmail.com abstract = We formalize the theory of homogeneous linear diophantine equations, focusing on two main results: (1) an abstract characterization of minimal complete sets of solutions, and (2) an algorithm computing them. Both, the characterization and the algorithm are based on previous work by Huet. Our starting point is a simple but inefficient variant of Huet's lexicographic algorithm incorporating improved bounds due to Clausen and Fortenbacher. We proceed by proving its soundness and completeness. Finally, we employ code equations to obtain a reasonably efficient implementation. Thus, we provide a formally verified solver for homogeneous linear diophantine equations. [Winding_Number_Eval] title = Evaluate Winding Numbers through Cauchy Indices author = Wenda Li topic = Mathematics/Analysis date = 2017-10-17 notify = wl302@cam.ac.uk, liwenda1990@hotmail.com abstract = In complex analysis, the winding number measures the number of times a path (counterclockwise) winds around a point, while the Cauchy index can approximate how the path winds. This entry provides a formalisation of the Cauchy index, which is then shown to be related to the winding number. In addition, this entry also offers a tactic that enables users to evaluate the winding number by calculating Cauchy indices. [Count_Complex_Roots] title = Count the Number of Complex Roots author = Wenda Li topic = Mathematics/Analysis date = 2017-10-17 notify = wl302@cam.ac.uk, liwenda1990@hotmail.com abstract = Based on evaluating Cauchy indices through remainder sequences, this entry provides an effective procedure to count the number of complex roots (with multiplicity) of a polynomial within a rectangle box or a half-plane. Potential applications of this entry include certified complex root isolation (of a polynomial) and testing the Routh-Hurwitz stability criterion (i.e., to check whether all the roots of some characteristic polynomial have negative real parts). [Buchi_Complementation] title = Büchi Complementation author = Julian Brunner topic = Computer science/Automata and formal languages date = 2017-10-19 notify = brunnerj@in.tum.de abstract = This entry provides a verified implementation of rank-based Büchi Complementation. The verification is done in three steps:
  1. Definition of odd rankings and proof that an automaton rejects a word iff there exists an odd ranking for it.
  2. Definition of the complement automaton and proof that it accepts exactly those words for which there is an odd ranking.
  3. Verified implementation of the complement automaton using the Isabelle Collections Framework.
[Transition_Systems_and_Automata] title = Transition Systems and Automata author = Julian Brunner topic = Computer science/Automata and formal languages date = 2017-10-19 notify = brunnerj@in.tum.de abstract = This entry provides a very abstract theory of transition systems that can be instantiated to express various types of automata. A transition system is typically instantiated by providing a set of initial states, a predicate for enabled transitions, and a transition execution function. From this, it defines the concepts of finite and infinite paths as well as the set of reachable states, among other things. Many useful theorems, from basic path manipulation rules to coinduction and run construction rules, are proven in this abstract transition system context. The library comes with instantiations for DFAs, NFAs, and Büchi automata. [Kuratowski_Closure_Complement] title = The Kuratowski Closure-Complement Theorem author = Peter Gammie , Gianpaolo Gioiosa<> topic = Mathematics/Topology date = 2017-10-26 notify = peteg42@gmail.com abstract = We discuss a topological curiosity discovered by Kuratowski (1922): the fact that the number of distinct operators on a topological space generated by compositions of closure and complement never exceeds 14, and is exactly 14 in the case of R. In addition, we prove a theorem due to Chagrov (1982) that classifies topological spaces according to the number of such operators they support. [Hybrid_Multi_Lane_Spatial_Logic] title = Hybrid Multi-Lane Spatial Logic author = Sven Linker topic = Logic/General logic/Modal logic date = 2017-11-06 notify = s.linker@liverpool.ac.uk abstract = We present a semantic embedding of a spatio-temporal multi-modal logic, specifically defined to reason about motorway traffic, into Isabelle/HOL. The semantic model is an abstraction of a motorway, emphasising local spatial properties, and parameterised by the types of sensors deployed in the vehicles. We use the logic to define controller constraints to ensure safety, i.e., the absence of collisions on the motorway. After proving safety with a restrictive definition of sensors, we relax these assumptions and show how to amend the controller constraints to still guarantee safety. [Dirichlet_L] title = Dirichlet L-Functions and Dirichlet's Theorem author = Manuel Eberl topic = Mathematics/Number theory, Mathematics/Algebra date = 2017-12-21 notify = eberlm@in.tum.de abstract =

This article provides a formalisation of Dirichlet characters and Dirichlet L-functions including proofs of their basic properties – most notably their analyticity, their areas of convergence, and their non-vanishing for ℜ(s) ≥ 1. All of this is built in a very high-level style using Dirichlet series. The proof of the non-vanishing follows a very short and elegant proof by Newman, which we attempt to reproduce faithfully in a similar level of abstraction in Isabelle.

This also leads to a relatively short proof of Dirichlet’s Theorem, which states that, if h and n are coprime, there are infinitely many primes p with p ≡ h (mod n).

[Symmetric_Polynomials] title = Symmetric Polynomials author = Manuel Eberl topic = Mathematics/Algebra date = 2018-09-25 notify = eberlm@in.tum.de abstract =

A symmetric polynomial is a polynomial in variables X1,…,Xn that does not discriminate between its variables, i. e. it is invariant under any permutation of them. These polynomials are important in the study of the relationship between the coefficients of a univariate polynomial and its roots in its algebraic closure.

This article provides a definition of symmetric polynomials and the elementary symmetric polynomials e1,…,en and proofs of their basic properties, including three notable ones:

  • Vieta's formula, which gives an explicit expression for the k-th coefficient of a univariate monic polynomial in terms of its roots x1,…,xn, namely ck = (-1)n-k en-k(x1,…,xn).
  • Second, the Fundamental Theorem of Symmetric Polynomials, which states that any symmetric polynomial is itself a uniquely determined polynomial combination of the elementary symmetric polynomials.
  • Third, as a corollary of the previous two, that given a polynomial over some ring R, any symmetric polynomial combination of its roots is also in R even when the roots are not.

Both the symmetry property itself and the witness for the Fundamental Theorem are executable.

[Taylor_Models] title = Taylor Models author = Christoph Traut<>, Fabian Immler topic = Computer science/Algorithms/Mathematical, Computer science/Data structures, Mathematics/Analysis, Mathematics/Algebra date = 2018-01-08 notify = immler@in.tum.de abstract = We present a formally verified implementation of multivariate Taylor models. Taylor models are a form of rigorous polynomial approximation, consisting of an approximation polynomial based on Taylor expansions, combined with a rigorous bound on the approximation error. Taylor models were introduced as a tool to mitigate the dependency problem of interval arithmetic. Our implementation automatically computes Taylor models for the class of elementary functions, expressed by composition of arithmetic operations and basic functions like exp, sin, or square root. [Green] title = An Isabelle/HOL formalisation of Green's Theorem author = Mohammad Abdulaziz , Lawrence C. Paulson topic = Mathematics/Analysis date = 2018-01-11 notify = mohammad.abdulaziz8@gmail.com, lp15@cam.ac.uk abstract = We formalise a statement of Green’s theorem—the first formalisation to our knowledge—in Isabelle/HOL. The theorem statement that we formalise is enough for most applications, especially in physics and engineering. Our formalisation is made possible by a novel proof that avoids the ubiquitous line integral cancellation argument. This eliminates the need to formalise orientations and region boundaries explicitly with respect to the outwards-pointing normal vector. Instead we appeal to a homological argument about equivalences between paths. [Gromov_Hyperbolicity] title = Gromov Hyperbolicity author = Sebastien Gouezel<> topic = Mathematics/Geometry date = 2018-01-16 notify = sebastien.gouezel@univ-rennes1.fr abstract = A geodesic metric space is Gromov hyperbolic if all its geodesic triangles are thin, i.e., every side is contained in a fixed thickening of the two other sides. While this definition looks innocuous, it has proved extremely important and versatile in modern geometry since its introduction by Gromov. We formalize the basic classical properties of Gromov hyperbolic spaces, notably the Morse lemma asserting that quasigeodesics are close to geodesics, the invariance of hyperbolicity under quasi-isometries, we define and study the Gromov boundary and its associated distance, and prove that a quasi-isometry between Gromov hyperbolic spaces extends to a homeomorphism of the boundaries. We also prove a less classical theorem, by Bonk and Schramm, asserting that a Gromov hyperbolic space embeds isometrically in a geodesic Gromov-hyperbolic space. As the original proof uses a transfinite sequence of Cauchy completions, this is an interesting formalization exercise. Along the way, we introduce basic material on isometries, quasi-isometries, Lipschitz maps, geodesic spaces, the Hausdorff distance, the Cauchy completion of a metric space, and the exponential on extended real numbers. [Ordered_Resolution_Prover] title = Formalization of Bachmair and Ganzinger's Ordered Resolution Prover author = Anders Schlichtkrull , Jasmin Christian Blanchette , Dmitriy Traytel , Uwe Waldmann topic = Logic/General logic/Mechanization of proofs date = 2018-01-18 notify = andschl@dtu.dk, j.c.blanchette@vu.nl abstract = This Isabelle/HOL formalization covers Sections 2 to 4 of Bachmair and Ganzinger's "Resolution Theorem Proving" chapter in the Handbook of Automated Reasoning. This includes soundness and completeness of unordered and ordered variants of ground resolution with and without literal selection, the standard redundancy criterion, a general framework for refutational theorem proving, and soundness and completeness of an abstract first-order prover. +[Chandy_Lamport] +title = A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm +author = Ben Fiedler , Dmitriy Traytel +topic = Computer science/Algorithms/Distributed +date = 2020-07-21 +notify = ben.fiedler@inf.ethz.ch, traytel@inf.ethz.ch +abstract = + We provide a suitable distributed system model and implementation of the + Chandy--Lamport distributed snapshot algorithm [ACM Transactions on + Computer Systems, 3, 63-75, 1985]. Our main result is a formal + termination and correctness proof of the Chandy--Lamport algorithm and + its use in stable property detection. + [BNF_Operations] title = Operations on Bounded Natural Functors author = Jasmin Christian Blanchette , Andrei Popescu , Dmitriy Traytel topic = Tools date = 2017-12-19 notify = jasmin.blanchette@gmail.com,uuomul@yahoo.com,traytel@inf.ethz.ch abstract = This entry formalizes the closure property of bounded natural functors (BNFs) under seven operations. These operations and the corresponding proofs constitute the core of Isabelle's (co)datatype package. To be close to the implemented tactics, the proofs are deliberately formulated as detailed apply scripts. The (co)datatypes together with (co)induction principles and (co)recursors are byproducts of the fixpoint operations LFP and GFP. Composition of BNFs is subdivided into four simpler operations: Compose, Kill, Lift, and Permute. The N2M operation provides mutual (co)induction principles and (co)recursors for nested (co)datatypes. [LLL_Basis_Reduction] title = A verified LLL algorithm author = Ralph Bottesch <>, Jose Divasón , Maximilian Haslbeck , Sebastiaan Joosten , René Thiemann , Akihisa Yamada<> topic = Computer science/Algorithms/Mathematical, Mathematics/Algebra date = 2018-02-02 notify = ralph.bottesch@uibk.ac.at, jose.divason@unirioja.es, maximilian.haslbeck@uibk.ac.at, s.j.c.joosten@utwente.nl, rene.thiemann@uibk.ac.at, ayamada@trs.cm.is.nagoya-u.ac.jp abstract = The Lenstra-Lenstra-Lovász basis reduction algorithm, also known as LLL algorithm, is an algorithm to find a basis with short, nearly orthogonal vectors of an integer lattice. Thereby, it can also be seen as an approximation to solve the shortest vector problem (SVP), which is an NP-hard problem, where the approximation quality solely depends on the dimension of the lattice, but not the lattice itself. The algorithm also possesses many applications in diverse fields of computer science, from cryptanalysis to number theory, but it is specially well-known since it was used to implement the first polynomial-time algorithm to factor polynomials. In this work we present the first mechanized soundness proof of the LLL algorithm to compute short vectors in lattices. The formalization follows a textbook by von zur Gathen and Gerhard. extra-history = Change history: [2018-04-16]: Integrated formal complexity bounds (Haslbeck, Thiemann) [2018-05-25]: Integrated much faster LLL implementation based on integer arithmetic (Bottesch, Haslbeck, Thiemann) [LLL_Factorization] title = A verified factorization algorithm for integer polynomials with polynomial complexity author = Jose Divasón , Sebastiaan Joosten , René Thiemann , Akihisa Yamada topic = Mathematics/Algebra date = 2018-02-06 notify = jose.divason@unirioja.es, s.j.c.joosten@utwente.nl, rene.thiemann@uibk.ac.at, ayamada@trs.cm.is.nagoya-u.ac.jp abstract = Short vectors in lattices and factors of integer polynomials are related. Each factor of an integer polynomial belongs to a certain lattice. When factoring polynomials, the condition that we are looking for an irreducible polynomial means that we must look for a small element in a lattice, which can be done by a basis reduction algorithm. In this development we formalize this connection and thereby one main application of the LLL basis reduction algorithm: an algorithm to factor square-free integer polynomials which runs in polynomial time. The work is based on our previous Berlekamp–Zassenhaus development, where the exponential reconstruction phase has been replaced by the polynomial-time basis reduction algorithm. Thanks to this formalization we found a serious flaw in a textbook. [Treaps] title = Treaps author = Maximilian Haslbeck , Manuel Eberl , Tobias Nipkow topic = Computer science/Data structures date = 2018-02-06 notify = eberlm@in.tum.de abstract =

A Treap is a binary tree whose nodes contain pairs consisting of some payload and an associated priority. It must have the search-tree property w.r.t. the payloads and the heap property w.r.t. the priorities. Treaps are an interesting data structure that is related to binary search trees (BSTs) in the following way: if one forgets all the priorities of a treap, the resulting BST is exactly the same as if one had inserted the elements into an empty BST in order of ascending priority. This means that a treap behaves like a BST where we can pretend the elements were inserted in a different order from the one in which they were actually inserted.

In particular, by choosing these priorities at random upon insertion of an element, we can pretend that we inserted the elements in random order, so that the shape of the resulting tree is that of a random BST no matter in what order we insert the elements. This is the main result of this formalisation.

[Skip_Lists] title = Skip Lists author = Max W. Haslbeck , Manuel Eberl topic = Computer science/Data structures date = 2020-01-09 notify = max.haslbeck@gmx.de abstract =

Skip lists are sorted linked lists enhanced with shortcuts and are an alternative to binary search trees. A skip lists consists of multiple levels of sorted linked lists where a list on level n is a subsequence of the list on level n − 1. In the ideal case, elements are skipped in such a way that a lookup in a skip lists takes O(log n) time. In a randomised skip list the skipped elements are choosen randomly.

This entry contains formalized proofs of the textbook results about the expected height and the expected length of a search path in a randomised skip list.

[Mersenne_Primes] title = Mersenne primes and the Lucas–Lehmer test author = Manuel Eberl topic = Mathematics/Number theory date = 2020-01-17 notify = eberlm@in.tum.de abstract =

This article provides formal proofs of basic properties of Mersenne numbers, i. e. numbers of the form 2n - 1, and especially of Mersenne primes.

In particular, an efficient, verified, and executable version of the Lucas–Lehmer test is developed. This test decides primality for Mersenne numbers in time polynomial in n.

[Hoare_Time] title = Hoare Logics for Time Bounds author = Maximilian P. L. Haslbeck , Tobias Nipkow topic = Computer science/Programming languages/Logics date = 2018-02-26 notify = haslbema@in.tum.de abstract = We study three different Hoare logics for reasoning about time bounds of imperative programs and formalize them in Isabelle/HOL: a classical Hoare like logic due to Nielson, a logic with potentials due to Carbonneaux et al. and a separation logic following work by Atkey, Chaguérand and Pottier. These logics are formally shown to be sound and complete. Verification condition generators are developed and are shown sound and complete too. We also consider variants of the systems where we abstract from multiplicative constants in the running time bounds, thus supporting a big-O style of reasoning. Finally we compare the expressive power of the three systems. [Architectural_Design_Patterns] title = A Theory of Architectural Design Patterns author = Diego Marmsoler topic = Computer science/System description languages date = 2018-03-01 notify = diego.marmsoler@tum.de abstract = The following document formalizes and verifies several architectural design patterns. Each pattern specification is formalized in terms of a locale where the locale assumptions correspond to the assumptions which a pattern poses on an architecture. Thus, pattern specifications may build on top of each other by interpreting the corresponding locale. A pattern is verified using the framework provided by the AFP entry Dynamic Architectures. Currently, the document consists of formalizations of 4 different patterns: the singleton, the publisher subscriber, the blackboard pattern, and the blockchain pattern. Thereby, the publisher component of the publisher subscriber pattern is modeled as an instance of the singleton pattern and the blackboard pattern is modeled as an instance of the publisher subscriber pattern. In general, this entry provides the first steps towards an overall theory of architectural design patterns. extra-history = Change history: [2018-05-25]: changing the major assumption for blockchain architectures from alternative minings to relative mining frequencies (revision 5043c5c71685)
[2019-04-08]: adapting the terminology: honest instead of trusted, dishonest instead of untrusted (revision 7af3431a22ae) [Weight_Balanced_Trees] title = Weight-Balanced Trees author = Tobias Nipkow , Stefan Dirix<> topic = Computer science/Data structures date = 2018-03-13 notify = nipkow@in.tum.de abstract = This theory provides a verified implementation of weight-balanced trees following the work of Hirai and Yamamoto who proved that all parameters in a certain range are valid, i.e. guarantee that insertion and deletion preserve weight-balance. Instead of a general theorem we provide parameterized proofs of preservation of the invariant that work for many (all?) valid parameters. [Fishburn_Impossibility] title = The Incompatibility of Fishburn-Strategyproofness and Pareto-Efficiency author = Felix Brandt , Manuel Eberl , Christian Saile , Christian Stricker topic = Mathematics/Games and economics date = 2018-03-22 notify = eberlm@in.tum.de abstract =

This formalisation contains the proof that there is no anonymous Social Choice Function for at least three agents and alternatives that fulfils both Pareto-Efficiency and Fishburn-Strategyproofness. It was derived from a proof of Brandt et al., which relies on an unverified translation of a fixed finite instance of the original problem to SAT. This Isabelle proof contains a machine-checked version of both the statement for exactly three agents and alternatives and the lifting to the general case.

[BNF_CC] title = Bounded Natural Functors with Covariance and Contravariance author = Andreas Lochbihler , Joshua Schneider topic = Computer science/Functional programming, Tools date = 2018-04-24 notify = mail@andreas-lochbihler.de, joshua.schneider@inf.ethz.ch abstract = Bounded natural functors (BNFs) provide a modular framework for the construction of (co)datatypes in higher-order logic. Their functorial operations, the mapper and relator, are restricted to a subset of the parameters, namely those where recursion can take place. For certain applications, such as free theorems, data refinement, quotients, and generalised rewriting, it is desirable that these operations do not ignore the other parameters. In this article, we formalise the generalisation BNFCC that extends the mapper and relator to covariant and contravariant parameters. We show that
  1. BNFCCs are closed under functor composition and least and greatest fixpoints,
  2. subtypes inherit the BNFCC structure under conditions that generalise those for the BNF case, and
  3. BNFCCs preserve quotients under mild conditions.
These proofs are carried out for abstract BNFCCs similar to the AFP entry BNF Operations. In addition, we apply the BNFCC theory to several concrete functors. [Modular_Assembly_Kit_Security] title = An Isabelle/HOL Formalization of the Modular Assembly Kit for Security Properties author = Oliver Bračevac , Richard Gay , Sylvia Grewe , Heiko Mantel , Henning Sudbrock , Markus Tasch topic = Computer science/Security date = 2018-05-07 notify = tasch@mais.informatik.tu-darmstadt.de abstract = The "Modular Assembly Kit for Security Properties" (MAKS) is a framework for both the definition and verification of possibilistic information-flow security properties at the specification-level. MAKS supports the uniform representation of a wide range of possibilistic information-flow properties and provides support for the verification of such properties via unwinding results and compositionality results. We provide a formalization of this framework in Isabelle/HOL. [AxiomaticCategoryTheory] title = Axiom Systems for Category Theory in Free Logic author = Christoph Benzmüller , Dana Scott topic = Mathematics/Category theory date = 2018-05-23 notify = c.benzmueller@gmail.com abstract = This document provides a concise overview on the core results of our previous work on the exploration of axioms systems for category theory. Extending the previous studies (http://arxiv.org/abs/1609.01493) we include one further axiomatic theory in our experiments. This additional theory has been suggested by Mac Lane in 1948. We show that the axioms proposed by Mac Lane are equivalent to the ones we studied before, which includes an axioms set suggested by Scott in the 1970s and another axioms set proposed by Freyd and Scedrov in 1990, which we slightly modified to remedy a minor technical issue. [OpSets] title = OpSets: Sequential Specifications for Replicated Datatypes author = Martin Kleppmann , Victor B. F. Gomes , Dominic P. Mulligan , Alastair R. Beresford topic = Computer science/Algorithms/Distributed, Computer science/Data structures date = 2018-05-10 notify = vb358@cam.ac.uk abstract = We introduce OpSets, an executable framework for specifying and reasoning about the semantics of replicated datatypes that provide eventual consistency in a distributed system, and for mechanically verifying algorithms that implement these datatypes. Our approach is simple but expressive, allowing us to succinctly specify a variety of abstract datatypes, including maps, sets, lists, text, graphs, trees, and registers. Our datatypes are also composable, enabling the construction of complex data structures. To demonstrate the utility of OpSets for analysing replication algorithms, we highlight an important correctness property for collaborative text editing that has traditionally been overlooked; algorithms that do not satisfy this property can exhibit awkward interleaving of text. We use OpSets to specify this correctness property and prove that although one existing replication algorithm satisfies this property, several other published algorithms do not. [Irrationality_J_Hancl] title = Irrational Rapidly Convergent Series author = Angeliki Koutsoukou-Argyraki , Wenda Li topic = Mathematics/Number theory, Mathematics/Analysis date = 2018-05-23 notify = ak2110@cam.ac.uk, wl302@cam.ac.uk abstract = We formalize with Isabelle/HOL a proof of a theorem by J. Hancl asserting the irrationality of the sum of a series consisting of rational numbers, built up by sequences that fulfill certain properties. Even though the criterion is a number theoretic result, the proof makes use only of analytical arguments. We also formalize a corollary of the theorem for a specific series fulfilling the assumptions of the theorem. [Optimal_BST] title = Optimal Binary Search Trees author = Tobias Nipkow , Dániel Somogyi <> topic = Computer science/Algorithms, Computer science/Data structures date = 2018-05-27 notify = nipkow@in.tum.de abstract = This article formalizes recursive algorithms for the construction of optimal binary search trees given fixed access frequencies. We follow Knuth (1971), Yao (1980) and Mehlhorn (1984). The algorithms are memoized with the help of the AFP article Monadification, Memoization and Dynamic Programming, thus yielding dynamic programming algorithms. [Projective_Geometry] title = Projective Geometry author = Anthony Bordg topic = Mathematics/Geometry date = 2018-06-14 notify = apdb3@cam.ac.uk abstract = We formalize the basics of projective geometry. In particular, we give a proof of the so-called Hessenberg's theorem in projective plane geometry. We also provide a proof of the so-called Desargues's theorem based on an axiomatization of (higher) projective space geometry using the notion of rank of a matroid. This last approach allows to handle incidence relations in an homogeneous way dealing only with points and without the need of talking explicitly about lines, planes or any higher entity. [Localization_Ring] title = The Localization of a Commutative Ring author = Anthony Bordg topic = Mathematics/Algebra date = 2018-06-14 notify = apdb3@cam.ac.uk abstract = We formalize the localization of a commutative ring R with respect to a multiplicative subset (i.e. a submonoid of R seen as a multiplicative monoid). This localization is itself a commutative ring and we build the natural homomorphism of rings from R to its localization. [Minsky_Machines] title = Minsky Machines author = Bertram Felgenhauer<> topic = Logic/Computability date = 2018-08-14 notify = int-e@gmx.de abstract =

We formalize undecidablity results for Minsky machines. To this end, we also formalize recursive inseparability.

We start by proving that Minsky machines can compute arbitrary primitive recursive and recursive functions. We then show that there is a deterministic Minsky machine with one argument and two final states such that the set of inputs that are accepted in one state is recursively inseparable from the set of inputs that are accepted in the other state.

As a corollary, the set of Minsky configurations that reach the first state but not the second recursively inseparable from the set of Minsky configurations that reach the second state but not the first. In particular both these sets are undecidable.

We do not prove that recursive functions can simulate Minsky machines.

[Neumann_Morgenstern_Utility] title = Von-Neumann-Morgenstern Utility Theorem author = Julian Parsert, Cezary Kaliszyk topic = Mathematics/Games and economics license = LGPL date = 2018-07-04 notify = julian.parsert@uibk.ac.at, cezary.kaliszyk@uibk.ac.at abstract = Utility functions form an essential part of game theory and economics. In order to guarantee the existence of utility functions most of the time sufficient properties are assumed in an axiomatic manner. One famous and very common set of such assumptions is that of expected utility theory. Here, the rationality, continuity, and independence of preferences is assumed. The von-Neumann-Morgenstern Utility theorem shows that these assumptions are necessary and sufficient for an expected utility function to exists. This theorem was proven by Neumann and Morgenstern in ``Theory of Games and Economic Behavior'' which is regarded as one of the most influential works in game theory. The formalization includes formal definitions of the underlying concepts including continuity and independence of preferences. [Simplex] title = An Incremental Simplex Algorithm with Unsatisfiable Core Generation author = Filip Marić , Mirko Spasić , René Thiemann topic = Computer science/Algorithms/Optimization date = 2018-08-24 notify = rene.thiemann@uibk.ac.at abstract = We present an Isabelle/HOL formalization and total correctness proof for the incremental version of the Simplex algorithm which is used in most state-of-the-art SMT solvers. It supports extraction of satisfying assignments, extraction of minimal unsatisfiable cores, incremental assertion of constraints and backtracking. The formalization relies on stepwise program refinement, starting from a simple specification, going through a number of refinement steps, and ending up in a fully executable functional implementation. Symmetries present in the algorithm are handled with special care. [Budan_Fourier] title = The Budan-Fourier Theorem and Counting Real Roots with Multiplicity author = Wenda Li topic = Mathematics/Analysis date = 2018-09-02 notify = wl302@cam.ac.uk, liwenda1990@hotmail.com abstract = This entry is mainly about counting and approximating real roots (of a polynomial) with multiplicity. We have first formalised the Budan-Fourier theorem: given a polynomial with real coefficients, we can calculate sign variations on Fourier sequences to over-approximate the number of real roots (counting multiplicity) within an interval. When all roots are known to be real, the over-approximation becomes tight: we can utilise this theorem to count real roots exactly. It is also worth noting that Descartes' rule of sign is a direct consequence of the Budan-Fourier theorem, and has been included in this entry. In addition, we have extended previous formalised Sturm's theorem to count real roots with multiplicity, while the original Sturm's theorem only counts distinct real roots. Compared to the Budan-Fourier theorem, our extended Sturm's theorem always counts roots exactly but may suffer from greater computational cost. [Quaternions] title = Quaternions author = Lawrence C. Paulson topic = Mathematics/Algebra, Mathematics/Geometry date = 2018-09-05 notify = lp15@cam.ac.uk abstract = This theory is inspired by the HOL Light development of quaternions, but follows its own route. Quaternions are developed coinductively, as in the existing formalisation of the complex numbers. Quaternions are quickly shown to belong to the type classes of real normed division algebras and real inner product spaces. And therefore they inherit a great body of facts involving algebraic laws, limits, continuity, etc., which must be proved explicitly in the HOL Light version. The development concludes with the geometric interpretation of the product of imaginary quaternions. [Octonions] title = Octonions author = Angeliki Koutsoukou-Argyraki topic = Mathematics/Algebra, Mathematics/Geometry date = 2018-09-14 notify = ak2110@cam.ac.uk abstract = We develop the basic theory of Octonions, including various identities and properties of the octonions and of the octonionic product, a description of 7D isometries and representations of orthogonal transformations. To this end we first develop the theory of the vector cross product in 7 dimensions. The development of the theory of Octonions is inspired by that of the theory of Quaternions by Lawrence Paulson. However, we do not work within the type class real_algebra_1 because the octonionic product is not associative. [Aggregation_Algebras] title = Aggregation Algebras author = Walter Guttmann topic = Mathematics/Algebra date = 2018-09-15 notify = walter.guttmann@canterbury.ac.nz abstract = We develop algebras for aggregation and minimisation for weight matrices and for edge weights in graphs. We verify the correctness of Prim's and Kruskal's minimum spanning tree algorithms based on these algebras. We also show numerous instances of these algebras based on linearly ordered commutative semigroups. [Prime_Number_Theorem] title = The Prime Number Theorem author = Manuel Eberl , Lawrence C. Paulson topic = Mathematics/Number theory date = 2018-09-19 notify = eberlm@in.tum.de abstract =

This article provides a short proof of the Prime Number Theorem in several equivalent forms, most notably π(x) ~ x/ln x where π(x) is the number of primes no larger than x. It also defines other basic number-theoretic functions related to primes like Chebyshev's functions ϑ and ψ and the “n-th prime number” function pn. We also show various bounds and relationship between these functions are shown. Lastly, we derive Mertens' First and Second Theorem, i. e. ∑p≤x ln p/p = ln x + O(1) and ∑p≤x 1/p = ln ln x + M + O(1/ln x). We also give explicit bounds for the remainder terms.

The proof of the Prime Number Theorem builds on a library of Dirichlet series and analytic combinatorics. We essentially follow the presentation by Newman. The core part of the proof is a Tauberian theorem for Dirichlet series, which is proven using complex analysis and then used to strengthen Mertens' First Theorem to ∑p≤x ln p/p = ln x + c + o(1).

A variant of this proof has been formalised before by Harrison in HOL Light, and formalisations of Selberg's elementary proof exist both by Avigad et al. in Isabelle and by Carneiro in Metamath. The advantage of the analytic proof is that, while it requires more powerful mathematical tools, it is considerably shorter and clearer. This article attempts to provide a short and clear formalisation of all components of that proof using the full range of mathematical machinery available in Isabelle, staying as close as possible to Newman's simple paper proof.

[Signature_Groebner] title = Signature-Based Gröbner Basis Algorithms author = Alexander Maletzky topic = Mathematics/Algebra, Computer science/Algorithms/Mathematical date = 2018-09-20 notify = alexander.maletzky@risc.jku.at abstract =

This article formalizes signature-based algorithms for computing Gröbner bases. Such algorithms are, in general, superior to other algorithms in terms of efficiency, and have not been formalized in any proof assistant so far. The present development is both generic, in the sense that most known variants of signature-based algorithms are covered by it, and effectively executable on concrete input thanks to Isabelle's code generator. Sample computations of benchmark problems show that the verified implementation of signature-based algorithms indeed outperforms the existing implementation of Buchberger's algorithm in Isabelle/HOL.

Besides total correctness of the algorithms, the article also proves that under certain conditions they a-priori detect and avoid all useless zero-reductions, and always return 'minimal' (in some sense) Gröbner bases if an input parameter is chosen in the right way.

The formalization follows the recent survey article by Eder and Faugère.

[Factored_Transition_System_Bounding] title = Upper Bounding Diameters of State Spaces of Factored Transition Systems author = Friedrich Kurz <>, Mohammad Abdulaziz topic = Computer science/Automata and formal languages, Mathematics/Graph theory date = 2018-10-12 notify = friedrich.kurz@tum.de, mohammad.abdulaziz@in.tum.de abstract = A completeness threshold is required to guarantee the completeness of planning as satisfiability, and bounded model checking of safety properties. One valid completeness threshold is the diameter of the underlying transition system. The diameter is the maximum element in the set of lengths of all shortest paths between pairs of states. The diameter is not calculated exactly in our setting, where the transition system is succinctly described using a (propositionally) factored representation. Rather, an upper bound on the diameter is calculated compositionally, by bounding the diameters of small abstract subsystems, and then composing those. We port a HOL4 formalisation of a compositional algorithm for computing a relatively tight upper bound on the system diameter. This compositional algorithm exploits acyclicity in the state space to achieve compositionality, and it was introduced by Abdulaziz et. al. The formalisation that we port is described as a part of another paper by Abdulaziz et. al. As a part of this porting we developed a libray about transition systems, which shall be of use in future related mechanisation efforts. [Smooth_Manifolds] title = Smooth Manifolds author = Fabian Immler , Bohua Zhan topic = Mathematics/Analysis, Mathematics/Topology date = 2018-10-22 notify = immler@in.tum.de, bzhan@ios.ac.cn abstract = We formalize the definition and basic properties of smooth manifolds in Isabelle/HOL. Concepts covered include partition of unity, tangent and cotangent spaces, and the fundamental theorem of path integrals. We also examine some concrete manifolds such as spheres and projective spaces. The formalization makes extensive use of the analysis and linear algebra libraries in Isabelle/HOL, in particular its “types-to-sets” mechanism. [Matroids] title = Matroids author = Jonas Keinholz<> topic = Mathematics/Combinatorics date = 2018-11-16 notify = eberlm@in.tum.de abstract =

This article defines the combinatorial structures known as Independence Systems and Matroids and provides basic concepts and theorems related to them. These structures play an important role in combinatorial optimisation, e. g. greedy algorithms such as Kruskal's algorithm. The development is based on Oxley's `What is a Matroid?'.

[Graph_Saturation] title = Graph Saturation author = Sebastiaan J. C. Joosten<> topic = Logic/Rewriting, Mathematics/Graph theory date = 2018-11-23 notify = sjcjoosten@gmail.com abstract = This is an Isabelle/HOL formalisation of graph saturation, closely following a paper by the author on graph saturation. Nine out of ten lemmas of the original paper are proven in this formalisation. The formalisation additionally includes two theorems that show the main premise of the paper: that consistency and entailment are decided through graph saturation. This formalisation does not give executable code, and it did not implement any of the optimisations suggested in the paper. [Functional_Ordered_Resolution_Prover] title = A Verified Functional Implementation of Bachmair and Ganzinger's Ordered Resolution Prover author = Anders Schlichtkrull , Jasmin Christian Blanchette , Dmitriy Traytel topic = Logic/General logic/Mechanization of proofs date = 2018-11-23 notify = andschl@dtu.dk,j.c.blanchette@vu.nl,traytel@inf.ethz.ch abstract = This Isabelle/HOL formalization refines the abstract ordered resolution prover presented in Section 4.3 of Bachmair and Ganzinger's "Resolution Theorem Proving" chapter in the Handbook of Automated Reasoning. The result is a functional implementation of a first-order prover. [Auto2_HOL] title = Auto2 Prover author = Bohua Zhan topic = Tools date = 2018-11-20 notify = bzhan@ios.ac.cn abstract = Auto2 is a saturation-based heuristic prover for higher-order logic, implemented as a tactic in Isabelle. This entry contains the instantiation of auto2 for Isabelle/HOL, along with two basic examples: solutions to some of the Pelletier’s problems, and elementary number theory of primes. [Order_Lattice_Props] title = Properties of Orderings and Lattices author = Georg Struth topic = Mathematics/Order date = 2018-12-11 notify = g.struth@sheffield.ac.uk abstract = These components add further fundamental order and lattice-theoretic concepts and properties to Isabelle's libraries. They follow by and large the introductory sections of the Compendium of Continuous Lattices, covering directed and filtered sets, down-closed and up-closed sets, ideals and filters, Galois connections, closure and co-closure operators. Some emphasis is on duality and morphisms between structures, as in the Compendium. To this end, three ad-hoc approaches to duality are compared. [Quantales] title = Quantales author = Georg Struth topic = Mathematics/Algebra date = 2018-12-11 notify = g.struth@sheffield.ac.uk abstract = These mathematical components formalise basic properties of quantales, together with some important models, constructions, and concepts, including quantic nuclei and conuclei. [Transformer_Semantics] title = Transformer Semantics author = Georg Struth topic = Mathematics/Algebra, Computer science/Semantics date = 2018-12-11 notify = g.struth@sheffield.ac.uk abstract = These mathematical components formalise predicate transformer semantics for programs, yet currently only for partial correctness and in the absence of faults. A first part for isotone (or monotone), Sup-preserving and Inf-preserving transformers follows Back and von Wright's approach, with additional emphasis on the quantalic structure of algebras of transformers. The second part develops Sup-preserving and Inf-preserving predicate transformers from the powerset monad, via its Kleisli category and Eilenberg-Moore algebras, with emphasis on adjunctions and dualities, as well as isomorphisms between relations, state transformers and predicate transformers. [Concurrent_Revisions] title = Formalization of Concurrent Revisions author = Roy Overbeek topic = Computer science/Concurrency date = 2018-12-25 notify = Roy.Overbeek@cwi.nl abstract = Concurrent revisions is a concurrency control model developed by Microsoft Research. It has many interesting properties that distinguish it from other well-known models such as transactional memory. One of these properties is determinacy: programs written within the model always produce the same outcome, independent of scheduling activity. The concurrent revisions model has an operational semantics, with an informal proof of determinacy. This document contains an Isabelle/HOL formalization of this semantics and the proof of determinacy. [Core_DOM] title = A Formal Model of the Document Object Model author = Achim D. Brucker , Michael Herzberg topic = Computer science/Data structures date = 2018-12-26 notify = adbrucker@0x5f.org abstract = In this AFP entry, we formalize the core of the Document Object Model (DOM). At its core, the DOM defines a tree-like data structure for representing documents in general and HTML documents in particular. It is the heart of any modern web browser. Formalizing the key concepts of the DOM is a prerequisite for the formal reasoning over client-side JavaScript programs and for the analysis of security concepts in modern web browsers. We present a formalization of the core DOM, with focus on the node-tree and the operations defined on node-trees, in Isabelle/HOL. We use the formalization to verify the functional correctness of the most important functions defined in the DOM standard. Moreover, our formalization is 1) extensible, i.e., can be extended without the need of re-proving already proven properties and 2) executable, i.e., we can generate executable code from our specification. [Store_Buffer_Reduction] title = A Reduction Theorem for Store Buffers author = Ernie Cohen , Norbert Schirmer topic = Computer science/Concurrency date = 2019-01-07 notify = norbert.schirmer@web.de abstract = When verifying a concurrent program, it is usual to assume that memory is sequentially consistent. However, most modern multiprocessors depend on store buffering for efficiency, and provide native sequential consistency only at a substantial performance penalty. To regain sequential consistency, a programmer has to follow an appropriate programming discipline. However, naïve disciplines, such as protecting all shared accesses with locks, are not flexible enough for building high-performance multiprocessor software. We present a new discipline for concurrent programming under TSO (total store order, with store buffer forwarding). It does not depend on concurrency primitives, such as locks. Instead, threads use ghost operations to acquire and release ownership of memory addresses. A thread can write to an address only if no other thread owns it, and can read from an address only if it owns it or it is shared and the thread has flushed its store buffer since it last wrote to an address it did not own. This discipline covers both coarse-grained concurrency (where data is protected by locks) as well as fine-grained concurrency (where atomic operations race to memory). We formalize this discipline in Isabelle/HOL, and prove that if every execution of a program in a system without store buffers follows the discipline, then every execution of the program with store buffers is sequentially consistent. Thus, we can show sequential consistency under TSO by ordinary assertional reasoning about the program, without having to consider store buffers at all. [IMP2] title = IMP2 – Simple Program Verification in Isabelle/HOL author = Peter Lammich , Simon Wimmer topic = Computer science/Programming languages/Logics, Computer science/Algorithms date = 2019-01-15 notify = lammich@in.tum.de abstract = IMP2 is a simple imperative language together with Isabelle tooling to create a program verification environment in Isabelle/HOL. The tools include a C-like syntax, a verification condition generator, and Isabelle commands for the specification of programs. The framework is modular, i.e., it allows easy reuse of already proved programs within larger programs. This entry comes with a quickstart guide and a large collection of examples, spanning basic algorithms with simple proofs to more advanced algorithms and proof techniques like data refinement. Some highlights from the examples are:
  • Bisection Square Root,
  • Extended Euclid,
  • Exponentiation by Squaring,
  • Binary Search,
  • Insertion Sort,
  • Quicksort,
  • Depth First Search.
The abstract syntax and semantics are very simple and well-documented. They are suitable to be used in a course, as extension to the IMP language which comes with the Isabelle distribution. While this entry is limited to a simple imperative language, the ideas could be extended to more sophisticated languages. [Farkas] title = Farkas' Lemma and Motzkin's Transposition Theorem author = Ralph Bottesch , Max W. Haslbeck , René Thiemann topic = Mathematics/Algebra date = 2019-01-17 notify = rene.thiemann@uibk.ac.at abstract = We formalize a proof of Motzkin's transposition theorem and Farkas' lemma in Isabelle/HOL. Our proof is based on the formalization of the simplex algorithm which, given a set of linear constraints, either returns a satisfying assignment to the problem or detects unsatisfiability. By reusing facts about the simplex algorithm we show that a set of linear constraints is unsatisfiable if and only if there is a linear combination of the constraints which evaluates to a trivially unsatisfiable inequality. [Auto2_Imperative_HOL] title = Verifying Imperative Programs using Auto2 author = Bohua Zhan topic = Computer science/Algorithms, Computer science/Data structures date = 2018-12-21 notify = bzhan@ios.ac.cn abstract = This entry contains the application of auto2 to verifying functional and imperative programs. Algorithms and data structures that are verified include linked lists, binary search trees, red-black trees, interval trees, priority queue, quicksort, union-find, Dijkstra's algorithm, and a sweep-line algorithm for detecting rectangle intersection. The imperative verification is based on Imperative HOL and its separation logic framework. A major goal of this work is to set up automation in order to reduce the length of proof that the user needs to provide, both for verifying functional programs and for working with separation logic. [UTP] title = Isabelle/UTP: Mechanised Theory Engineering for Unifying Theories of Programming author = Simon Foster , Frank Zeyda<>, Yakoub Nemouchi , Pedro Ribeiro<>, Burkhart Wolff topic = Computer science/Programming languages/Logics date = 2019-02-01 notify = simon.foster@york.ac.uk abstract = Isabelle/UTP is a mechanised theory engineering toolkit based on Hoare and He’s Unifying Theories of Programming (UTP). UTP enables the creation of denotational, algebraic, and operational semantics for different programming languages using an alphabetised relational calculus. We provide a semantic embedding of the alphabetised relational calculus in Isabelle/HOL, including new type definitions, relational constructors, automated proof tactics, and accompanying algebraic laws. Isabelle/UTP can be used to both capture laws of programming for different languages, and put these fundamental theorems to work in the creation of associated verification tools, using calculi like Hoare logics. This document describes the relational core of the UTP in Isabelle/HOL. [HOL-CSP] title = HOL-CSP Version 2.0 author = Safouan Taha , Lina Ye , Burkhart Wolff topic = Computer science/Concurrency/Process calculi, Computer science/Semantics date = 2019-04-26 notify = wolff@lri.fr abstract = This is a complete formalization of the work of Hoare and Roscoe on the denotational semantics of the Failure/Divergence Model of CSP. It follows essentially the presentation of CSP in Roscoe’s Book ”Theory and Practice of Concurrency” [8] and the semantic details in a joint Paper of Roscoe and Brooks ”An improved failures model for communicating processes". The present work is based on a prior formalization attempt, called HOL-CSP 1.0, done in 1997 by H. Tej and B. Wolff with the Isabelle proof technology available at that time. This work revealed minor, but omnipresent foundational errors in key concepts like the process invariant. The present version HOL-CSP profits from substantially improved libraries (notably HOLCF), improved automated proof techniques, and structured proof techniques in Isar and is substantially shorter but more complete. [Probabilistic_Prime_Tests] title = Probabilistic Primality Testing author = Daniel Stüwe<>, Manuel Eberl topic = Mathematics/Number theory date = 2019-02-11 notify = eberlm@in.tum.de abstract =

The most efficient known primality tests are probabilistic in the sense that they use randomness and may, with some probability, mistakenly classify a composite number as prime – but never a prime number as composite. Examples of this are the Miller–Rabin test, the Solovay–Strassen test, and (in most cases) Fermat's test.

This entry defines these three tests and proves their correctness. It also develops some of the number-theoretic foundations, such as Carmichael numbers and the Jacobi symbol with an efficient executable algorithm to compute it.

[Kruskal] title = Kruskal's Algorithm for Minimum Spanning Forest author = Maximilian P.L. Haslbeck , Peter Lammich , Julian Biendarra<> topic = Computer science/Algorithms/Graph date = 2019-02-14 notify = haslbema@in.tum.de, lammich@in.tum.de abstract = This Isabelle/HOL formalization defines a greedy algorithm for finding a minimum weight basis on a weighted matroid and proves its correctness. This algorithm is an abstract version of Kruskal's algorithm. We interpret the abstract algorithm for the cycle matroid (i.e. forests in a graph) and refine it to imperative executable code using an efficient union-find data structure. Our formalization can be instantiated for different graph representations. We provide instantiations for undirected graphs and symmetric directed graphs. [List_Inversions] title = The Inversions of a List author = Manuel Eberl topic = Computer science/Algorithms date = 2019-02-01 notify = eberlm@in.tum.de abstract =

This entry defines the set of inversions of a list, i.e. the pairs of indices that violate sortedness. It also proves the correctness of the well-known O(n log n) divide-and-conquer algorithm to compute the number of inversions.

[Prime_Distribution_Elementary] title = Elementary Facts About the Distribution of Primes author = Manuel Eberl topic = Mathematics/Number theory date = 2019-02-21 notify = eberlm@in.tum.de abstract =

This entry is a formalisation of Chapter 4 (and parts of Chapter 3) of Apostol's Introduction to Analytic Number Theory. The main topics that are addressed are properties of the distribution of prime numbers that can be shown in an elementary way (i. e. without the Prime Number Theorem), the various equivalent forms of the PNT (which imply each other in elementary ways), and consequences that follow from the PNT in elementary ways. The latter include, most notably, asymptotic bounds for the number of distinct prime factors of n, the divisor function d(n), Euler's totient function φ(n), and lcm(1,…,n).

[Safe_OCL] title = Safe OCL author = Denis Nikiforov <> topic = Computer science/Programming languages/Language definitions license = LGPL date = 2019-03-09 notify = denis.nikif@gmail.com abstract =

The theory is a formalization of the OCL type system, its abstract syntax and expression typing rules. The theory does not define a concrete syntax and a semantics. In contrast to Featherweight OCL, it is based on a deep embedding approach. The type system is defined from scratch, it is not based on the Isabelle HOL type system.

The Safe OCL distincts nullable and non-nullable types. Also the theory gives a formal definition of safe navigation operations. The Safe OCL typing rules are much stricter than rules given in the OCL specification. It allows one to catch more errors on a type checking phase.

The type theory presented is four-layered: classes, basic types, generic types, errorable types. We introduce the following new types: non-nullable types (T[1]), nullable types (T[?]), OclSuper. OclSuper is a supertype of all other types (basic types, collections, tuples). This type allows us to define a total supremum function, so types form an upper semilattice. It allows us to define rich expression typing rules in an elegant manner.

The Preliminaries Chapter of the theory defines a number of helper lemmas for transitive closures and tuples. It defines also a generic object model independent from OCL. It allows one to use the theory as a reference for formalization of analogous languages.

[QHLProver] title = Quantum Hoare Logic author = Junyi Liu<>, Bohua Zhan , Shuling Wang<>, Shenggang Ying<>, Tao Liu<>, Yangjia Li<>, Mingsheng Ying<>, Naijun Zhan<> topic = Computer science/Programming languages/Logics, Computer science/Semantics date = 2019-03-24 notify = bzhan@ios.ac.cn abstract = We formalize quantum Hoare logic as given in [1]. In particular, we specify the syntax and denotational semantics of a simple model of quantum programs. Then, we write down the rules of quantum Hoare logic for partial correctness, and show the soundness and completeness of the resulting proof system. As an application, we verify the correctness of Grover’s algorithm. [Transcendence_Series_Hancl_Rucki] title = The Transcendence of Certain Infinite Series author = Angeliki Koutsoukou-Argyraki , Wenda Li topic = Mathematics/Analysis, Mathematics/Number theory date = 2019-03-27 notify = wl302@cam.ac.uk, ak2110@cam.ac.uk abstract = We formalize the proofs of two transcendence criteria by J. Hančl and P. Rucki that assert the transcendence of the sums of certain infinite series built up by sequences that fulfil certain properties. Both proofs make use of Roth's celebrated theorem on diophantine approximations to algebraic numbers from 1955 which we implement as an assumption without having formalised its proof. [Binding_Syntax_Theory] title = A General Theory of Syntax with Bindings author = Lorenzo Gheri , Andrei Popescu topic = Computer science/Programming languages/Lambda calculi, Computer science/Functional programming, Logic/General logic/Mechanization of proofs date = 2019-04-06 notify = a.popescu@mdx.ac.uk, lor.gheri@gmail.com abstract = We formalize a theory of syntax with bindings that has been developed and refined over the last decade to support several large formalization efforts. Terms are defined for an arbitrary number of constructors of varying numbers of inputs, quotiented to alpha-equivalence and sorted according to a binding signature. The theory includes many properties of the standard operators on terms: substitution, swapping and freshness. It also includes bindings-aware induction and recursion principles and support for semantic interpretation. This work has been presented in the ITP 2017 paper “A Formalized General Theory of Syntax with Bindings”. [LTL_Master_Theorem] title = A Compositional and Unified Translation of LTL into ω-Automata author = Benedikt Seidl , Salomon Sickert topic = Computer science/Automata and formal languages date = 2019-04-16 notify = benedikt.seidl@tum.de, s.sickert@tum.de abstract = We present a formalisation of the unified translation approach of linear temporal logic (LTL) into ω-automata from [1]. This approach decomposes LTL formulas into ``simple'' languages and allows a clear separation of concerns: first, we formalise the purely logical result yielding this decomposition; second, we instantiate this generic theory to obtain a construction for deterministic (state-based) Rabin automata (DRA). We extract from this particular instantiation an executable tool translating LTL to DRAs. To the best of our knowledge this is the first verified translation from LTL to DRAs that is proven to be double exponential in the worst case which asymptotically matches the known lower bound.

[1] Javier Esparza, Jan Kretínský, Salomon Sickert. One Theorem to Rule Them All: A Unified Translation of LTL into ω-Automata. LICS 2018 [LambdaAuth] title = Formalization of Generic Authenticated Data Structures author = Matthias Brun<>, Dmitriy Traytel topic = Computer science/Security, Computer science/Programming languages/Lambda calculi date = 2019-05-14 notify = traytel@inf.ethz.ch abstract = Authenticated data structures are a technique for outsourcing data storage and maintenance to an untrusted server. The server is required to produce an efficiently checkable and cryptographically secure proof that it carried out precisely the requested computation. Miller et al. introduced λ• (pronounced lambda auth)—a functional programming language with a built-in primitive authentication construct, which supports a wide range of user-specified authenticated data structures while guaranteeing certain correctness and security properties for all well-typed programs. We formalize λ• and prove its correctness and security properties. With Isabelle's help, we uncover and repair several mistakes in the informal proofs and lemma statements. Our findings are summarized in a paper draft. [IMP2_Binary_Heap] title = Binary Heaps for IMP2 author = Simon Griebel<> topic = Computer science/Data structures, Computer science/Algorithms date = 2019-06-13 notify = s.griebel@tum.de abstract = In this submission array-based binary minimum heaps are formalized. The correctness of the following heap operations is proved: insert, get-min, delete-min and make-heap. These are then used to verify an in-place heapsort. The formalization is based on IMP2, an imperative program verification framework implemented in Isabelle/HOL. The verified heap functions are iterative versions of the partly recursive functions found in "Algorithms and Data Structures – The Basic Toolbox" by K. Mehlhorn and P. Sanders and "Introduction to Algorithms" by T. H. Cormen, C. E. Leiserson, R. L. Rivest and C. Stein. [Groebner_Macaulay] title = Gröbner Bases, Macaulay Matrices and Dubé's Degree Bounds author = Alexander Maletzky topic = Mathematics/Algebra date = 2019-06-15 notify = alexander.maletzky@risc.jku.at abstract = This entry formalizes the connection between Gröbner bases and Macaulay matrices (sometimes also referred to as `generalized Sylvester matrices'). In particular, it contains a method for computing Gröbner bases, which proceeds by first constructing some Macaulay matrix of the initial set of polynomials, then row-reducing this matrix, and finally converting the result back into a set of polynomials. The output is shown to be a Gröbner basis if the Macaulay matrix constructed in the first step is sufficiently large. In order to obtain concrete upper bounds on the size of the matrix (and hence turn the method into an effectively executable algorithm), Dubé's degree bounds on Gröbner bases are utilized; consequently, they are also part of the formalization. [Linear_Inequalities] title = Linear Inequalities author = Ralph Bottesch , Alban Reynaud <>, René Thiemann topic = Mathematics/Algebra date = 2019-06-21 notify = rene.thiemann@uibk.ac.at abstract = We formalize results about linear inqualities, mainly from Schrijver's book. The main results are the proof of the fundamental theorem on linear inequalities, Farkas' lemma, Carathéodory's theorem, the Farkas-Minkowsky-Weyl theorem, the decomposition theorem of polyhedra, and Meyer's result that the integer hull of a polyhedron is a polyhedron itself. Several theorems include bounds on the appearing numbers, and in particular we provide an a-priori bound on mixed-integer solutions of linear inequalities. [Linear_Programming] title = Linear Programming author = Julian Parsert , Cezary Kaliszyk topic = Mathematics/Algebra date = 2019-08-06 notify = julian.parsert@gmail.com, cezary.kaliszyk@uibk.ac.at abstract = We use the previous formalization of the general simplex algorithm to formulate an algorithm for solving linear programs. We encode the linear programs using only linear constraints. Solving these constraints also solves the original linear program. This algorithm is proven to be sound by applying the weak duality theorem which is also part of this formalization. [Differential_Game_Logic] title = Differential Game Logic author = André Platzer topic = Computer science/Programming languages/Logics date = 2019-06-03 notify = aplatzer@cs.cmu.edu abstract = This formalization provides differential game logic (dGL), a logic for proving properties of hybrid game. In addition to the syntax and semantics, it formalizes a uniform substitution calculus for dGL. Church's uniform substitutions substitute a term or formula for a function or predicate symbol everywhere. The uniform substitutions for dGL also substitute hybrid games for a game symbol everywhere. We prove soundness of one-pass uniform substitutions and the axioms of differential game logic with respect to their denotational semantics. One-pass uniform substitutions are faster by postponing soundness-critical admissibility checks with a linear pass homomorphic application and regain soundness by a variable condition at the replacements. The formalization is based on prior non-mechanized soundness proofs for dGL. [Complete_Non_Orders] title = Complete Non-Orders and Fixed Points author = Akihisa Yamada , Jérémy Dubut topic = Mathematics/Order date = 2019-06-27 notify = akihisayamada@nii.ac.jp, dubut@nii.ac.jp abstract = We develop an Isabelle/HOL library of order-theoretic concepts, such as various completeness conditions and fixed-point theorems. We keep our formalization as general as possible: we reprove several well-known results about complete orders, often without any properties of ordering, thus complete non-orders. In particular, we generalize the Knaster–Tarski theorem so that we ensure the existence of a quasi-fixed point of monotone maps over complete non-orders, and show that the set of quasi-fixed points is complete under a mild condition—attractivity—which is implied by either antisymmetry or transitivity. This result generalizes and strengthens a result by Stauti and Maaden. Finally, we recover Kleene’s fixed-point theorem for omega-complete non-orders, again using attractivity to prove that Kleene’s fixed points are least quasi-fixed points. [Priority_Search_Trees] title = Priority Search Trees author = Peter Lammich , Tobias Nipkow topic = Computer science/Data structures date = 2019-06-25 notify = lammich@in.tum.de abstract = We present a new, purely functional, simple and efficient data structure combining a search tree and a priority queue, which we call a priority search tree. The salient feature of priority search trees is that they offer a decrease-key operation, something that is missing from other simple, purely functional priority queue implementations. Priority search trees can be implemented on top of any search tree. This entry does the implementation for red-black trees. This entry formalizes the first part of our ITP-2019 proof pearl Purely Functional, Simple and Efficient Priority Search Trees and Applications to Prim and Dijkstra. [Prim_Dijkstra_Simple] title = Purely Functional, Simple, and Efficient Implementation of Prim and Dijkstra author = Peter Lammich , Tobias Nipkow topic = Computer science/Algorithms/Graph date = 2019-06-25 notify = lammich@in.tum.de abstract = We verify purely functional, simple and efficient implementations of Prim's and Dijkstra's algorithms. This constitutes the first verification of an executable and even efficient version of Prim's algorithm. This entry formalizes the second part of our ITP-2019 proof pearl Purely Functional, Simple and Efficient Priority Search Trees and Applications to Prim and Dijkstra. [MFOTL_Monitor] title = Formalization of a Monitoring Algorithm for Metric First-Order Temporal Logic author = Joshua Schneider , Dmitriy Traytel topic = Computer science/Algorithms, Logic/General logic/Temporal logic, Computer science/Automata and formal languages date = 2019-07-04 notify = joshua.schneider@inf.ethz.ch, traytel@inf.ethz.ch abstract = A monitor is a runtime verification tool that solves the following problem: Given a stream of time-stamped events and a policy formulated in a specification language, decide whether the policy is satisfied at every point in the stream. We verify the correctness of an executable monitor for specifications given as formulas in metric first-order temporal logic (MFOTL), an expressive extension of linear temporal logic with real-time constraints and first-order quantification. The verified monitor implements a simplified variant of the algorithm used in the efficient MonPoly monitoring tool. The formalization is presented in a RV 2019 paper, which also compares the output of the verified monitor to that of other monitoring tools on randomly generated inputs. This case study revealed several errors in the optimized but unverified tools. extra-history = Change history: [2020-08-13]: added the formalization of the abstract slicing framework and joint data slicer (revision b1639ed541b7)
[FOL_Seq_Calc1] title = A Sequent Calculus for First-Order Logic author = Asta Halkjær From contributors = Alexander Birch Jensen , Anders Schlichtkrull , Jørgen Villadsen topic = Logic/Proof theory date = 2019-07-18 notify = ahfrom@dtu.dk abstract = This work formalizes soundness and completeness of a one-sided sequent calculus for first-order logic. The completeness is shown via a translation from a complete semantic tableau calculus, the proof of which is based on the First-Order Logic According to Fitting theory. The calculi and proof techniques are taken from Ben-Ari's Mathematical Logic for Computer Science. [Szpilrajn] title = Szpilrajn Extension Theorem author = Peter Zeller topic = Mathematics/Order date = 2019-07-27 notify = p_zeller@cs.uni-kl.de abstract = We formalize the Szpilrajn extension theorem, also known as order-extension principal: Every strict partial order can be extended to a strict linear order. [TESL_Language] title = A Formal Development of a Polychronous Polytimed Coordination Language author = Hai Nguyen Van , Frédéric Boulanger , Burkhart Wolff topic = Computer science/System description languages, Computer science/Semantics, Computer science/Concurrency date = 2019-07-30 notify = frederic.boulanger@centralesupelec.fr, burkhart.wolff@lri.fr abstract = The design of complex systems involves different formalisms for modeling their different parts or aspects. The global model of a system may therefore consist of a coordination of concurrent sub-models that use different paradigms. We develop here a theory for a language used to specify the timed coordination of such heterogeneous subsystems by addressing the following issues:

  • the behavior of the sub-systems is observed only at a series of discrete instants,
  • events may occur in different sub-systems at unrelated times, leading to polychronous systems, which do not necessarily have a common base clock,
  • coordination between subsystems involves causality, so the occurrence of an event may enforce the occurrence of other events, possibly after a certain duration has elapsed or an event has occurred a given number of times,
  • the domain of time (discrete, rational, continuous...) may be different in the subsystems, leading to polytimed systems,
  • the time frames of different sub-systems may be related (for instance, time in a GPS satellite and in a GPS receiver on Earth are related although they are not the same).
Firstly, a denotational semantics of the language is defined. Then, in order to be able to incrementally check the behavior of systems, an operational semantics is given, with proofs of progress, soundness and completeness with regard to the denotational semantics. These proofs are made according to a setup that can scale up when new operators are added to the language. In order for specifications to be composed in a clean way, the language should be invariant by stuttering (i.e., adding observation instants at which nothing happens). The proof of this invariance is also given. [Stellar_Quorums] title = Stellar Quorum Systems author = Giuliano Losa topic = Computer science/Algorithms/Distributed date = 2019-08-01 notify = giuliano@galois.com abstract = We formalize the static properties of personal Byzantine quorum systems (PBQSs) and Stellar quorum systems, as described in the paper ``Stellar Consensus by Reduction'' (to appear at DISC 2019). [IMO2019] title = Selected Problems from the International Mathematical Olympiad 2019 author = Manuel Eberl topic = Mathematics/Misc date = 2019-08-05 notify = eberlm@in.tum.de abstract =

This entry contains formalisations of the answers to three of the six problem of the International Mathematical Olympiad 2019, namely Q1, Q4, and Q5.

The reason why these problems were chosen is that they are particularly amenable to formalisation: they can be solved with minimal use of libraries. The remaining three concern geometry and graph theory, which, in the author's opinion, are more difficult to formalise resp. require a more complex library.

[Adaptive_State_Counting] title = Formalisation of an Adaptive State Counting Algorithm author = Robert Sachtleben topic = Computer science/Automata and formal languages, Computer science/Algorithms date = 2019-08-16 notify = rob_sac@uni-bremen.de abstract = This entry provides a formalisation of a refinement of an adaptive state counting algorithm, used to test for reduction between finite state machines. The algorithm has been originally presented by Hierons in the paper Testing from a Non-Deterministic Finite State Machine Using Adaptive State Counting. Definitions for finite state machines and adaptive test cases are given and many useful theorems are derived from these. The algorithm is formalised using mutually recursive functions, for which it is proven that the generated test suite is sufficient to test for reduction against finite state machines of a certain fault domain. Additionally, the algorithm is specified in a simple WHILE-language and its correctness is shown using Hoare-logic. [Jacobson_Basic_Algebra] title = A Case Study in Basic Algebra author = Clemens Ballarin topic = Mathematics/Algebra date = 2019-08-30 notify = ballarin@in.tum.de abstract = The focus of this case study is re-use in abstract algebra. It contains locale-based formalisations of selected parts of set, group and ring theory from Jacobson's Basic Algebra leading to the respective fundamental homomorphism theorems. The study is not intended as a library base for abstract algebra. It rather explores an approach towards abstract algebra in Isabelle. [Hybrid_Systems_VCs] title = Verification Components for Hybrid Systems author = Jonathan Julian Huerta y Munive <> topic = Mathematics/Algebra, Mathematics/Analysis date = 2019-09-10 notify = jjhuertaymunive1@sheffield.ac.uk, jonjulian23@gmail.com abstract = These components formalise a semantic framework for the deductive verification of hybrid systems. They support reasoning about continuous evolutions of hybrid programs in the style of differential dynamics logic. Vector fields or flows model these evolutions, and their verification is done with invariants for the former or orbits for the latter. Laws of modal Kleene algebra or categorical predicate transformers implement the verification condition generation. Examples show the approach at work. [Generic_Join] title = Formalization of Multiway-Join Algorithms author = Thibault Dardinier<> topic = Computer science/Algorithms date = 2019-09-16 notify = tdardini@student.ethz.ch, traytel@inf.ethz.ch abstract = Worst-case optimal multiway-join algorithms are recent seminal achievement of the database community. These algorithms compute the natural join of multiple relational databases and improve in the worst case over traditional query plan optimizations of nested binary joins. In 2014, Ngo, Ré, and Rudra gave a unified presentation of different multi-way join algorithms. We formalized and proved correct their "Generic Join" algorithm and extended it to support negative joins. [Aristotles_Assertoric_Syllogistic] title = Aristotle's Assertoric Syllogistic author = Angeliki Koutsoukou-Argyraki topic = Logic/Philosophical aspects date = 2019-10-08 notify = ak2110@cam.ac.uk abstract = We formalise with Isabelle/HOL some basic elements of Aristotle's assertoric syllogistic following the article from the Stanford Encyclopedia of Philosophy by Robin Smith. To this end, we use a set theoretic formulation (covering both individual and general predication). In particular, we formalise the deductions in the Figures and after that we present Aristotle's metatheoretical observation that all deductions in the Figures can in fact be reduced to either Barbara or Celarent. As the formal proofs prove to be straightforward, the interest of this entry lies in illustrating the functionality of Isabelle and high efficiency of Sledgehammer for simple exercises in philosophy. [VerifyThis2019] title = VerifyThis 2019 -- Polished Isabelle Solutions author = Peter Lammich<>, Simon Wimmer topic = Computer science/Algorithms date = 2019-10-16 notify = lammich@in.tum.de, wimmers@in.tum.de abstract = VerifyThis 2019 (http://www.pm.inf.ethz.ch/research/verifythis.html) was a program verification competition associated with ETAPS 2019. It was the 8th event in the VerifyThis competition series. In this entry, we present polished and completed versions of our solutions that we created during the competition. [ZFC_in_HOL] title = Zermelo Fraenkel Set Theory in Higher-Order Logic author = Lawrence C. Paulson topic = Logic/Set theory date = 2019-10-24 notify = lp15@cam.ac.uk abstract =

This entry is a new formalisation of ZFC set theory in Isabelle/HOL. It is logically equivalent to Obua's HOLZF; the point is to have the closest possible integration with the rest of Isabelle/HOL, minimising the amount of new notations and exploiting type classes.

There is a type V of sets and a function elts :: V => V set mapping a set to its elements. Classes simply have type V set, and a predicate identifies the small classes: those that correspond to actual sets. Type classes connected with orders and lattices are used to minimise the amount of new notation for concepts such as the subset relation, union and intersection. Basic concepts — Cartesian products, disjoint sums, natural numbers, functions, etc. — are formalised.

More advanced set-theoretic concepts, such as transfinite induction, ordinals, cardinals and the transitive closure of a set, are also provided. The definition of addition and multiplication for general sets (not just ordinals) follows Kirby.

The theory provides two type classes with the aim of facilitating developments that combine V with other Isabelle/HOL types: embeddable, the class of types that can be injected into V (including V itself as well as V*V, etc.), and small, the class of types that correspond to some ZF set.

extra-history = Change history: [2020-01-28]: Generalisation of the "small" predicate and order types to arbitrary sets; ordinal exponentiation; introduction of the coercion ord_of_nat :: "nat => V"; numerous new lemmas. (revision 6081d5be8d08) [Interval_Arithmetic_Word32] title = Interval Arithmetic on 32-bit Words author = Brandon Bohrer topic = Computer science/Data structures date = 2019-11-27 notify = bjbohrer@gmail.com, bbohrer@cs.cmu.edu abstract = Interval_Arithmetic implements conservative interval arithmetic computations, then uses this interval arithmetic to implement a simple programming language where all terms have 32-bit signed word values, with explicit infinities for terms outside the representable bounds. Our target use case is interpreters for languages that must have a well-understood low-level behavior. We include a formalization of bounded-length strings which are used for the identifiers of our language. Bounded-length identifiers are useful in some applications, for example the Differential_Dynamic_Logic article, where a Euclidean space indexed by identifiers demands that identifiers are finitely many. [Generalized_Counting_Sort] title = An Efficient Generalization of Counting Sort for Large, possibly Infinite Key Ranges author = Pasquale Noce topic = Computer science/Algorithms, Computer science/Functional programming date = 2019-12-04 notify = pasquale.noce.lavoro@gmail.com abstract = Counting sort is a well-known algorithm that sorts objects of any kind mapped to integer keys, or else to keys in one-to-one correspondence with some subset of the integers (e.g. alphabet letters). However, it is suitable for direct use, viz. not just as a subroutine of another sorting algorithm (e.g. radix sort), only if the key range is not significantly larger than the number of the objects to be sorted. This paper describes a tail-recursive generalization of counting sort making use of a bounded number of counters, suitable for direct use in case of a large, or even infinite key range of any kind, subject to the only constraint of being a subset of an arbitrary linear order. After performing a pen-and-paper analysis of how such algorithm has to be designed to maximize its efficiency, this paper formalizes the resulting generalized counting sort (GCsort) algorithm and then formally proves its correctness properties, namely that (a) the counters' number is maximized never exceeding the fixed upper bound, (b) objects are conserved, (c) objects get sorted, and (d) the algorithm is stable. [Poincare_Bendixson] title = The Poincaré-Bendixson Theorem author = Fabian Immler , Yong Kiam Tan topic = Mathematics/Analysis date = 2019-12-18 notify = fimmler@cs.cmu.edu, yongkiat@cs.cmu.edu abstract = The Poincaré-Bendixson theorem is a classical result in the study of (continuous) dynamical systems. Colloquially, it restricts the possible behaviors of planar dynamical systems: such systems cannot be chaotic. In practice, it is a useful tool for proving the existence of (limiting) periodic behavior in planar systems. The theorem is an interesting and challenging benchmark for formalized mathematics because proofs in the literature rely on geometric sketches and only hint at symmetric cases. It also requires a substantial background of mathematical theories, e.g., the Jordan curve theorem, real analysis, ordinary differential equations, and limiting (long-term) behavior of dynamical systems. [Isabelle_C] title = Isabelle/C author = Frédéric Tuong , Burkhart Wolff topic = Computer science/Programming languages/Language definitions, Computer science/Semantics, Tools date = 2019-10-22 notify = tuong@users.gforge.inria.fr, wolff@lri.fr abstract = We present a framework for C code in C11 syntax deeply integrated into the Isabelle/PIDE development environment. Our framework provides an abstract interface for verification back-ends to be plugged-in independently. Thus, various techniques such as deductive program verification or white-box testing can be applied to the same source, which is part of an integrated PIDE document model. Semantic back-ends are free to choose the supported C fragment and its semantics. In particular, they can differ on the chosen memory model or the specification mechanism for framing conditions. Our framework supports semantic annotations of C sources in the form of comments. Annotations serve to locally control back-end settings, and can express the term focus to which an annotation refers. Both the logical and the syntactic context are available when semantic annotations are evaluated. As a consequence, a formula in an annotation can refer both to HOL or C variables. Our approach demonstrates the degree of maturity and expressive power the Isabelle/PIDE sub-system has achieved in recent years. Our integration technique employs Lex and Yacc style grammars to ensure efficient deterministic parsing. This is the core-module of Isabelle/C; the AFP package for Clean and Clean_wrapper as well as AutoCorres and AutoCorres_wrapper (available via git) are applications of this front-end. [Zeta_3_Irrational] title = The Irrationality of ζ(3) author = Manuel Eberl topic = Mathematics/Number theory date = 2019-12-27 notify = manuel.eberl@tum.de abstract =

This article provides a formalisation of Beukers's straightforward analytic proof that ζ(3) is irrational. This was first proven by Apéry (which is why this result is also often called ‘Apéry's Theorem’) using a more algebraic approach. This formalisation follows Filaseta's presentation of Beukers's proof.

[Hybrid_Logic] title = Formalizing a Seligman-Style Tableau System for Hybrid Logic author = Asta Halkjær From topic = Logic/General logic/Modal logic date = 2019-12-20 notify = ahfrom@dtu.dk abstract = This work is a formalization of soundness and completeness proofs for a Seligman-style tableau system for hybrid logic. The completeness result is obtained via a synthetic approach using maximally consistent sets of tableau blocks. The formalization differs from previous work in a few ways. First, to avoid the need to backtrack in the construction of a tableau, the formalized system has no unnamed initial segment, and therefore no Name rule. Second, I show that the full Bridge rule is admissible in the system. Third, I start from rules restricted to only extend the branch with new formulas, including only witnessing diamonds that are not already witnessed, and show that the unrestricted rules are admissible. Similarly, I start from simpler versions of the @-rules and show that these are sufficient. The GoTo rule is restricted using a notion of potential such that each application consumes potential and potential is earned through applications of the remaining rules. I show that if a branch can be closed then it can be closed starting from a single unit. Finally, Nom is restricted by a fixed set of allowed nominals. The resulting system should be terminating. extra-history = Change history: [2020-06-03]: The fully restricted system has been shown complete by updating the synthetic completeness proof. [Bicategory] title = Bicategories author = Eugene W. Stark topic = Mathematics/Category theory date = 2020-01-06 notify = stark@cs.stonybrook.edu abstract = Taking as a starting point the author's previous work on developing aspects of category theory in Isabelle/HOL, this article gives a compatible formalization of the notion of "bicategory" and develops a framework within which formal proofs of facts about bicategories can be given. The framework includes a number of basic results, including the Coherence Theorem, the Strictness Theorem, pseudofunctors and biequivalence, and facts about internal equivalences and adjunctions in a bicategory. As a driving application and demonstration of the utility of the framework, it is used to give a formal proof of a theorem, due to Carboni, Kasangian, and Street, that characterizes up to biequivalence the bicategories of spans in a category with pullbacks. The formalization effort necessitated the filling-in of many details that were not evident from the brief presentation in the original paper, as well as identifying a few minor corrections along the way. extra-history = Change history: [2020-02-15]: Move ConcreteCategory.thy from Bicategory to Category3 and use it systematically. Make other minor improvements throughout. (revision a51840d36867)
[Subset_Boolean_Algebras] title = A Hierarchy of Algebras for Boolean Subsets author = Walter Guttmann , Bernhard Möller topic = Mathematics/Algebra date = 2020-01-31 notify = walter.guttmann@canterbury.ac.nz abstract = We present a collection of axiom systems for the construction of Boolean subalgebras of larger overall algebras. The subalgebras are defined as the range of a complement-like operation on a semilattice. This technique has been used, for example, with the antidomain operation, dynamic negation and Stone algebras. We present a common ground for these constructions based on a new equational axiomatisation of Boolean algebras. [Goodstein_Lambda] title = Implementing the Goodstein Function in λ-Calculus author = Bertram Felgenhauer topic = Logic/Rewriting date = 2020-02-21 notify = int-e@gmx.de abstract = In this formalization, we develop an implementation of the Goodstein function G in plain λ-calculus, linked to a concise, self-contained specification. The implementation works on a Church-encoded representation of countable ordinals. The initial conversion to hereditary base 2 is not covered, but the material is sufficient to compute the particular value G(16), and easily extends to other fixed arguments. [VeriComp] title = A Generic Framework for Verified Compilers author = Martin Desharnais topic = Computer science/Programming languages/Compiling date = 2020-02-10 notify = martin.desharnais@unibw.de abstract = This is a generic framework for formalizing compiler transformations. It leverages Isabelle/HOL’s locales to abstract over concrete languages and transformations. It states common definitions for language semantics, program behaviours, forward and backward simulations, and compilers. We provide generic operations, such as simulation and compiler composition, and prove general (partial) correctness theorems, resulting in reusable proof components. [Hello_World] title = Hello World author = Cornelius Diekmann , Lars Hupel topic = Computer science/Functional programming date = 2020-03-07 notify = diekmann@net.in.tum.de abstract = In this article, we present a formalization of the well-known "Hello, World!" code, including a formal framework for reasoning about IO. Our model is inspired by the handling of IO in Haskell. We start by formalizing the 🌍 and embrace the IO monad afterwards. Then we present a sample main :: IO (), followed by its proof of correctness. [WOOT_Strong_Eventual_Consistency] title = Strong Eventual Consistency of the Collaborative Editing Framework WOOT author = Emin Karayel , Edgar Gonzàlez topic = Computer science/Algorithms/Distributed date = 2020-03-25 notify = eminkarayel@google.com, edgargip@google.com, me@eminkarayel.de abstract = Commutative Replicated Data Types (CRDTs) are a promising new class of data structures for large-scale shared mutable content in applications that only require eventual consistency. The WithOut Operational Transforms (WOOT) framework is a CRDT for collaborative text editing introduced by Oster et al. (CSCW 2006) for which the eventual consistency property was verified only for a bounded model to date. We contribute a formal proof for WOOTs strong eventual consistency. [Furstenberg_Topology] title = Furstenberg's topology and his proof of the infinitude of primes author = Manuel Eberl topic = Mathematics/Number theory date = 2020-03-22 notify = manuel.eberl@tum.de abstract =

This article gives a formal version of Furstenberg's topological proof of the infinitude of primes. He defines a topology on the integers based on arithmetic progressions (or, equivalently, residue classes). Using some fairly obvious properties of this topology, the infinitude of primes is then easily obtained.

Apart from this, this topology is also fairly ‘nice’ in general: it is second countable, metrizable, and perfect. All of these (well-known) facts are formally proven, including an explicit metric for the topology given by Zulfeqarr.

[Saturation_Framework] title = A Comprehensive Framework for Saturation Theorem Proving author = Sophie Tourret topic = Logic/General logic/Mechanization of proofs date = 2020-04-09 notify = stourret@mpi-inf.mpg.de abstract = This Isabelle/HOL formalization is the companion of the technical report “A comprehensive framework for saturation theorem proving”, itself companion of the eponym IJCAR 2020 paper, written by Uwe Waldmann, Sophie Tourret, Simon Robillard and Jasmin Blanchette. It verifies a framework for formal refutational completeness proofs of abstract provers that implement saturation calculi, such as ordered resolution or superposition, and allows to model entire prover architectures in such a way that the static refutational completeness of a calculus immediately implies the dynamic refutational completeness of a prover implementing the calculus using a variant of the given clause loop. The technical report “A comprehensive framework for saturation theorem proving” is available on the Matryoshka website. The names of the Isabelle lemmas and theorems corresponding to the results in the report are indicated in the margin of the report. [Saturation_Framework_Extensions] title = Extensions to the Comprehensive Framework for Saturation Theorem Proving author = Jasmin Blanchette , Sophie Tourret topic = Logic/General logic/Mechanization of proofs date = 2020-08-25 notify = jasmin.blanchette@gmail.com abstract = This Isabelle/HOL formalization extends the AFP entry Saturation_Framework with the following contributions:
  • an application of the framework to prove Bachmair and Ganzinger's resolution prover RP refutationally complete, which was formalized in a more ad hoc fashion by Schlichtkrull et al. in the AFP entry Ordered_Resultion_Prover;
  • generalizations of various basic concepts formalized by Schlichtkrull et al., which were needed to verify RP and could be useful to formalize other calculi, such as superposition;
  • alternative proofs of fairness (and hence saturation and ultimately refutational completeness) for the given clause procedures GC and LGC, based on invariance.
[MFODL_Monitor_Optimized] title = Formalization of an Optimized Monitoring Algorithm for Metric First-Order Dynamic Logic with Aggregations author = Thibault Dardinier<>, Lukas Heimes<>, Martin Raszyk , Joshua Schneider , Dmitriy Traytel topic = Computer science/Algorithms, Logic/General logic/Modal logic, Computer science/Automata and formal languages date = 2020-04-09 notify = martin.raszyk@inf.ethz.ch, joshua.schneider@inf.ethz.ch, traytel@inf.ethz.ch abstract = A monitor is a runtime verification tool that solves the following problem: Given a stream of time-stamped events and a policy formulated in a specification language, decide whether the policy is satisfied at every point in the stream. We verify the correctness of an executable monitor for specifications given as formulas in metric first-order dynamic logic (MFODL), which combines the features of metric first-order temporal logic (MFOTL) and metric dynamic logic. Thus, MFODL supports real-time constraints, first-order parameters, and regular expressions. Additionally, the monitor supports aggregation operations such as count and sum. This formalization, which is described in a forthcoming paper at IJCAR 2020, significantly extends previous work on a verified monitor for MFOTL. Apart from the addition of regular expressions and aggregations, we implemented multi-way joins and a specialized sliding window algorithm to further optimize the monitor. [Sliding_Window_Algorithm] title = Formalization of an Algorithm for Greedily Computing Associative Aggregations on Sliding Windows author = Lukas Heimes<>, Dmitriy Traytel , Joshua Schneider<> topic = Computer science/Algorithms date = 2020-04-10 notify = heimesl@student.ethz.ch, traytel@inf.ethz.ch, joshua.schneider@inf.ethz.ch abstract = Basin et al.'s sliding window algorithm (SWA) is an algorithm for combining the elements of subsequences of a sequence with an associative operator. It is greedy and minimizes the number of operator applications. We formalize the algorithm and verify its functional correctness. We extend the algorithm with additional operations and provide an alternative interface to the slide operation that does not require the entire input sequence. [Lucas_Theorem] title = Lucas's Theorem author = Chelsea Edmonds topic = Mathematics/Number theory date = 2020-04-07 notify = cle47@cam.ac.uk abstract = This work presents a formalisation of a generating function proof for Lucas's theorem. We first outline extensions to the existing Formal Power Series (FPS) library, including an equivalence relation for coefficients modulo n, an alternate binomial theorem statement, and a formalised proof of the Freshman's dream (mod p) lemma. The second part of the work presents the formal proof of Lucas's Theorem. Working backwards, the formalisation first proves a well known corollary of the theorem which is easier to formalise, and then applies induction to prove the original theorem statement. The proof of the corollary aims to provide a good example of a formalised generating function equivalence proof using the FPS library. The final theorem statement is intended to be integrated into the formalised proof of Hilbert's 10th Problem. [ADS_Functor] title = Authenticated Data Structures As Functors author = Andreas Lochbihler , Ognjen Marić topic = Computer science/Data structures date = 2020-04-16 notify = andreas.lochbihler@digitalasset.com, mail@andreas-lochbihler.de abstract = Authenticated data structures allow several systems to convince each other that they are referring to the same data structure, even if each of them knows only a part of the data structure. Using inclusion proofs, knowledgeable systems can selectively share their knowledge with other systems and the latter can verify the authenticity of what is being shared. In this article, we show how to modularly define authenticated data structures, their inclusion proofs, and operations thereon as datatypes in Isabelle/HOL, using a shallow embedding. Modularity allows us to construct complicated trees from reusable building blocks, which we call Merkle functors. Merkle functors include sums, products, and function spaces and are closed under composition and least fixpoints. As a practical application, we model the hierarchical transactions of Canton, a practical interoperability protocol for distributed ledgers, as authenticated data structures. This is a first step towards formalizing the Canton protocol and verifying its integrity and security guarantees. [Power_Sum_Polynomials] title = Power Sum Polynomials author = Manuel Eberl topic = Mathematics/Algebra date = 2020-04-24 notify = eberlm@in.tum.de abstract =

This article provides a formalisation of the symmetric multivariate polynomials known as power sum polynomials. These are of the form pn(X1,…, Xk) = X1n + … + Xkn. A formal proof of the Girard–Newton Theorem is also given. This theorem relates the power sum polynomials to the elementary symmetric polynomials sk in the form of a recurrence relation (-1)k k sk = ∑i∈[0,k) (-1)i si pk-i .

As an application, this is then used to solve a generalised form of a puzzle given as an exercise in Dummit and Foote's Abstract Algebra: For k complex unknowns x1, …, xk, define pj := x1j + … + xkj. Then for each vector a ∈ ℂk, show that there is exactly one solution to the system p1 = a1, …, pk = ak up to permutation of the xi and determine the value of pi for i>k.

[Gaussian_Integers] title = Gaussian Integers author = Manuel Eberl topic = Mathematics/Number theory date = 2020-04-24 notify = eberlm@in.tum.de abstract =

The Gaussian integers are the subring ℤ[i] of the complex numbers, i. e. the ring of all complex numbers with integral real and imaginary part. This article provides a definition of this ring as well as proofs of various basic properties, such as that they form a Euclidean ring and a full classification of their primes. An executable (albeit not very efficient) factorisation algorithm is also provided.

Lastly, this Gaussian integer formalisation is used in two short applications:

  1. The characterisation of all positive integers that can be written as sums of two squares
  2. Euclid's formula for primitive Pythagorean triples

While elementary proofs for both of these are already available in the AFP, the theory of Gaussian integers provides more concise proofs and a more high-level view.

[Forcing] title = Formalization of Forcing in Isabelle/ZF author = Emmanuel Gunther , Miguel Pagano , Pedro Sánchez Terraf topic = Logic/Set theory date = 2020-05-06 notify = gunther@famaf.unc.edu.ar, pagano@famaf.unc.edu.ar, sterraf@famaf.unc.edu.ar abstract = We formalize the theory of forcing in the set theory framework of Isabelle/ZF. Under the assumption of the existence of a countable transitive model of ZFC, we construct a proper generic extension and show that the latter also satisfies ZFC. [Recursion-Addition] title = Recursion Theorem in ZF author = Georgy Dunaev topic = Logic/Set theory date = 2020-05-11 notify = georgedunaev@gmail.com abstract = This document contains a proof of the recursion theorem. This is a mechanization of the proof of the recursion theorem from the text Introduction to Set Theory, by Karel Hrbacek and Thomas Jech. This implementation may be used as the basis for a model of Peano arithmetic in ZF. While recursion and the natural numbers are already available in Isabelle/ZF, this clean development is much easier to follow. [LTL_Normal_Form] title = An Efficient Normalisation Procedure for Linear Temporal Logic: Isabelle/HOL Formalisation author = Salomon Sickert topic = Computer science/Automata and formal languages, Logic/General logic/Temporal logic date = 2020-05-08 notify = s.sickert@tum.de abstract = In the mid 80s, Lichtenstein, Pnueli, and Zuck proved a classical theorem stating that every formula of Past LTL (the extension of LTL with past operators) is equivalent to a formula of the form $\bigwedge_{i=1}^n \mathbf{G}\mathbf{F} \varphi_i \vee \mathbf{F}\mathbf{G} \psi_i$, where $\varphi_i$ and $\psi_i$ contain only past operators. Some years later, Chang, Manna, and Pnueli built on this result to derive a similar normal form for LTL. Both normalisation procedures have a non-elementary worst-case blow-up, and follow an involved path from formulas to counter-free automata to star-free regular expressions and back to formulas. We improve on both points. We present an executable formalisation of a direct and purely syntactic normalisation procedure for LTL yielding a normal form, comparable to the one by Chang, Manna, and Pnueli, that has only a single exponential blow-up. [Matrices_for_ODEs] title = Matrices for ODEs author = Jonathan Julian Huerta y Munive topic = Mathematics/Analysis, Mathematics/Algebra date = 2020-04-19 notify = jonjulian23@gmail.com abstract = Our theories formalise various matrix properties that serve to establish existence, uniqueness and characterisation of the solution to affine systems of ordinary differential equations (ODEs). In particular, we formalise the operator and maximum norm of matrices. Then we use them to prove that square matrices form a Banach space, and in this setting, we show an instance of Picard-Lindelöf’s theorem for affine systems of ODEs. Finally, we use this formalisation to verify three simple hybrid programs. [Irrational_Series_Erdos_Straus] title = Irrationality Criteria for Series by Erdős and Straus author = Angeliki Koutsoukou-Argyraki , Wenda Li topic = Mathematics/Number theory, Mathematics/Analysis date = 2020-05-12 notify = ak2110@cam.ac.uk, wl302@cam.ac.uk, liwenda1990@hotmail.com abstract = We formalise certain irrationality criteria for infinite series of the form: \[\sum_{n=1}^\infty \frac{b_n}{\prod_{i=1}^n a_i} \] where $\{b_n\}$ is a sequence of integers and $\{a_n\}$ a sequence of positive integers with $a_n >1$ for all large n. The results are due to P. Erdős and E. G. Straus [1]. In particular, we formalise Theorem 2.1, Corollary 2.10 and Theorem 3.1. The latter is an application of Theorem 2.1 involving the prime numbers. [Knuth_Bendix_Order] title = A Formalization of Knuth–Bendix Orders author = Christian Sternagel , René Thiemann topic = Logic/Rewriting date = 2020-05-13 notify = c.sternagel@gmail.com, rene.thiemann@uibk.ac.at abstract = We define a generalized version of Knuth–Bendix orders, including subterm coefficient functions. For these orders we formalize several properties such as strong normalization, the subterm property, closure properties under substitutions and contexts, as well as ground totality. [Stateful_Protocol_Composition_and_Typing] title = Stateful Protocol Composition and Typing author = Andreas V. Hess , Sebastian Mödersheim , Achim D. Brucker topic = Computer science/Security date = 2020-04-08 notify = avhe@dtu.dk, andreasvhess@gmail.com, samo@dtu.dk, brucker@spamfence.net, andschl@dtu.dk abstract = We provide in this AFP entry several relative soundness results for security protocols. In particular, we prove typing and compositionality results for stateful protocols (i.e., protocols with mutable state that may span several sessions), and that focuses on reachability properties. Such results are useful to simplify protocol verification by reducing it to a simpler problem: Typing results give conditions under which it is safe to verify a protocol in a typed model where only "well-typed" attacks can occur whereas compositionality results allow us to verify a composed protocol by only verifying the component protocols in isolation. The conditions on the protocols under which the results hold are furthermore syntactic in nature allowing for full automation. The foundation presented here is used in another entry to provide fully automated and formalized security proofs of stateful protocols. [Automated_Stateful_Protocol_Verification] title = Automated Stateful Protocol Verification author = Andreas V. Hess , Sebastian Mödersheim , Achim D. Brucker , Anders Schlichtkrull topic = Computer science/Security, Tools date = 2020-04-08 notify = avhe@dtu.dk, andreasvhess@gmail.com, samo@dtu.dk, brucker@spamfence.net, andschl@dtu.dk abstract = In protocol verification we observe a wide spectrum from fully automated methods to interactive theorem proving with proof assistants like Isabelle/HOL. In this AFP entry, we present a fully-automated approach for verifying stateful security protocols, i.e., protocols with mutable state that may span several sessions. The approach supports reachability goals like secrecy and authentication. We also include a simple user-friendly transaction-based protocol specification language that is embedded into Isabelle. [Smith_Normal_Form] title = A verified algorithm for computing the Smith normal form of a matrix author = Jose Divasón topic = Mathematics/Algebra, Computer science/Algorithms/Mathematical date = 2020-05-23 notify = jose.divason@unirioja.es abstract = This work presents a formal proof in Isabelle/HOL of an algorithm to transform a matrix into its Smith normal form, a canonical matrix form, in a general setting: the algorithm is parameterized by operations to prove its existence over elementary divisor rings, while execution is guaranteed over Euclidean domains. We also provide a formal proof on some results about the generality of this algorithm as well as the uniqueness of the Smith normal form. Since Isabelle/HOL does not feature dependent types, the development is carried out switching conveniently between two different existing libraries: the Hermite normal form (based on HOL Analysis) and the Jordan normal form AFP entries. This permits to reuse results from both developments and it is done by means of the lifting and transfer package together with the use of local type definitions. [Nash_Williams] title = The Nash-Williams Partition Theorem author = Lawrence C. Paulson topic = Mathematics/Combinatorics date = 2020-05-16 notify = lp15@cam.ac.uk abstract = In 1965, Nash-Williams discovered a generalisation of the infinite form of Ramsey's theorem. Where the latter concerns infinite sets of n-element sets for some fixed n, the Nash-Williams theorem concerns infinite sets of finite sets (or lists) subject to a “no initial segment” condition. The present formalisation follows a monograph on Ramsey Spaces by Todorčević. [Safe_Distance] title = A Formally Verified Checker of the Safe Distance Traffic Rules for Autonomous Vehicles author = Albert Rizaldi , Fabian Immler topic = Computer science/Algorithms/Mathematical, Mathematics/Physics date = 2020-06-01 notify = albert.rizaldi@ntu.edu.sg, fimmler@andrew.cmu.edu, martin.rau@tum.de abstract = The Vienna Convention on Road Traffic defines the safe distance traffic rules informally. This could make autonomous vehicle liable for safe-distance-related accidents because there is no clear definition of how large a safe distance is. We provide a formally proven prescriptive definition of a safe distance, and checkers which can decide whether an autonomous vehicle is obeying the safe distance rule. Not only does our work apply to the domain of law, but it also serves as a specification for autonomous vehicle manufacturers and for online verification of path planners. +[Relational_Paths] +title = Relational Characterisations of Paths +author = Walter Guttmann , Peter Höfner +topic = Mathematics/Graph theory +date = 2020-07-13 +notify = walter.guttmann@canterbury.ac.nz, peter@hoefner-online.de +abstract = + Binary relations are one of the standard ways to encode, characterise + and reason about graphs. Relation algebras provide equational axioms + for a large fragment of the calculus of binary relations. Although + relations are standard tools in many areas of mathematics and + computing, researchers usually fall back to point-wise reasoning when + it comes to arguments about paths in a graph. We present a purely + algebraic way to specify different kinds of paths in Kleene relation + algebras, which are relation algebras equipped with an operation for + reflexive transitive closure. We study the relationship between paths + with a designated root vertex and paths without such a vertex. Since + we stay in first-order logic this development helps with mechanising + proofs. To demonstrate the applicability of the algebraic framework we + verify the correctness of three basic graph algorithms. + +[Amicable_Numbers] +title = Amicable Numbers +author = Angeliki Koutsoukou-Argyraki +topic = Mathematics/Number theory +date = 2020-08-04 +notify = ak2110@cam.ac.uk +abstract = + This is a formalisation of Amicable Numbers, involving some relevant + material including Euler's sigma function, some relevant + definitions, results and examples as well as rules such as + Thābit ibn Qurra's Rule, Euler's Rule, te + Riele's Rule and Borho's Rule with breeders. + +[Ordinal_Partitions] +title = Ordinal Partitions +author = Lawrence C. Paulson +topic = Mathematics/Combinatorics, Logic/Set theory +date = 2020-08-03 +notify = lp15@cam.ac.uk +abstract = + The theory of partition relations concerns generalisations of + Ramsey's theorem. For any ordinal $\alpha$, write $\alpha \to + (\alpha, m)^2$ if for each function $f$ from unordered pairs of + elements of $\alpha$ into $\{0,1\}$, either there is a subset + $X\subseteq \alpha$ order-isomorphic to $\alpha$ such that + $f\{x,y\}=0$ for all $\{x,y\}\subseteq X$, or there is an $m$ element + set $Y\subseteq \alpha$ such that $f\{x,y\}=1$ for all + $\{x,y\}\subseteq Y$. (In both cases, with $\{x,y\}$ we require + $x\not=y$.) In particular, the infinite Ramsey theorem can be written + in this notation as $\omega \to (\omega, \omega)^2$, or if we + restrict $m$ to the positive integers as above, then $\omega \to + (\omega, m)^2$ for all $m$. This entry formalises Larson's proof + of $\omega^\omega \to (\omega^\omega, m)^2$ along with a similar proof + of a result due to Specker: $\omega^2 \to (\omega^2, m)^2$. Also + proved is a necessary result by Erdős and Milner: + $\omega^{1+\alpha\cdot n} \to (\omega^{1+\alpha}, 2^n)^2$. + +[Relational_Disjoint_Set_Forests] +title = Relational Disjoint-Set Forests +author = Walter Guttmann +topic = Computer science/Data structures +date = 2020-08-26 +notify = walter.guttmann@canterbury.ac.nz +abstract = + We give a simple relation-algebraic semantics of read and write + operations on associative arrays. The array operations seamlessly + integrate with assignments in the Hoare-logic library. Using relation + algebras and Kleene algebras we verify the correctness of an + array-based implementation of disjoint-set forests with a naive union + operation and a find operation with path compression. + diff --git a/thys/Amicable_Numbers/Amicable_Numbers.thy b/thys/Amicable_Numbers/Amicable_Numbers.thy new file mode 100644 --- /dev/null +++ b/thys/Amicable_Numbers/Amicable_Numbers.thy @@ -0,0 +1,1537 @@ +(*Author: Angeliki Koutsoukou-Argyraki, University of Cambridge. +Date: 3 August 2020. + +text\This is a formalisation of Amicable Numbers, involving some relevant material including +Euler's sigma function, some relevant definitions, results and examples as well as rules such as +Th\={a}bit ibn Qurra's Rule, Euler's Rule, te Riele's Rule and Borho's Rule with breeders.\*) + +theory "Amicable_Numbers" + imports "HOL-Number_Theory.Number_Theory" + "HOL-Computational_Algebra.Computational_Algebra" + Pratt_Certificate.Pratt_Certificate_Code + Polynomial_Factorization.Prime_Factorization + +begin + +section\Miscellaneous\ + +lemma mult_minus_eq_nat: + fixes x::nat and y ::nat and z::nat + assumes " x+y = z" + shows " -x-y = -z " + using assms by linarith + +lemma minus_eq_nat_subst: fixes A::nat and B::nat and C::nat and D::nat and E::nat + assumes "A = B-C-D" and " -E = -C-D" + shows " A = B-E" + using assms by linarith + +lemma minus_eq_nat_subst_order: fixes A::nat and B::nat and C::nat and D::nat and E::nat + assumes "B-C-D > 0" and "A = B-C-D+B" shows "A = 2*B-C-D" + using assms by auto + +lemma auxiliary_ineq: fixes x::nat assumes "x \ (2::nat)" + shows " x+1 < (2::nat)*x" + using assms by linarith + +(* TODO The following three auxiliary lemmas are by Lawrence Paulson. To be added to the library. *) + +lemma sum_strict_mono: + fixes A :: "nat set" + assumes "finite B" "A \ B" "0 \ B" + shows "\ A < \ B" +proof - + have "B - A \ {}" + using assms(2) by blast + with assms DiffE have "\ (B-A) > 0" + by fastforce + moreover have "\ B = \ A + \ (B-A)" + by (metis add.commute assms(1) assms(2) psubsetE sum.subset_diff) + ultimately show ?thesis + by linarith +qed + +lemma sum_image_eq: + assumes "inj_on f A" + shows "\ (f ` A) = (\ i \ A. f i)" + using assms sum.reindex_cong by fastforce + +lemma coprime_dvd_aux: + assumes "gcd m n = Suc 0" "na dvd n" "ma dvd m" "mb dvd m" "nb dvd n" and eq: "ma * na = mb * nb" + shows "ma = mb" +proof - + have "gcd na mb = 1" + using assms by (metis One_nat_def gcd.commute gcd_nat.mono is_unit_gcd_iff) + moreover have "gcd nb ma = 1" + using assms by (metis One_nat_def gcd.commute gcd_nat.mono is_unit_gcd_iff) + ultimately show "ma = mb" + by (metis eq gcd_mult_distrib_nat mult.commute nat_mult_1_right) +qed + +section\Amicable Numbers\ + +subsection\Preliminaries\ + +definition divisor :: "nat \nat \ bool" (infixr "divisor" 80) + where "n divisor m \(n \ 1 \ n \ m \ n dvd m)" + +definition divisor_set: "divisor_set m = {n. n divisor m}" + +lemma def_equiv_divisor_set: "divisor_set (n::nat) = set(divisors_nat n)" + using divisors_nat_def divisors_nat divisor_set divisor_def by auto + +definition proper_divisor :: "nat \nat \ bool" (infixr "properdiv" 80) + where "n properdiv m \(n \ 1 \ n < m \ n dvd m)" + +definition properdiv_set: "properdiv_set m = {n. n properdiv m}" + +lemma example1_divisor: shows "(2::nat) \ divisor_set (4::nat)" + using divisor_set divisor_def by force + +lemma example2_properdiv_set: "properdiv_set (Suc (Suc (Suc 0))) = {(1::nat)}" + by (auto simp: properdiv_set proper_divisor_def less_Suc_eq dvd_def; presburger) + +lemma divisor_set_not_empty: fixes m::nat assumes "m \1" + shows "m \ divisor_set m" +using assms divisor_set divisor_def by force + +lemma finite_divisor_set [simp]: "finite(divisor_set n)" + using divisor_def divisor_set by simp + +lemma finite_properdiv_set[simp]: shows "finite(properdiv_set m)" + using properdiv_set proper_divisor_def by simp + +lemma divisor_set_mult: + "divisor_set (m*n) = {i*j| i j. (i \ divisor_set m)\(j \ divisor_set n)}" + using divisor_set divisor_def + by (fastforce simp add: divisor_set divisor_def dest: division_decomp) + +lemma divisor_set_1 [simp]: "divisor_set (Suc 0) = {Suc 0}" + by (simp add: divisor_set divisor_def cong: conj_cong) + +lemma divisor_set_one: shows "divisor_set 1 ={1}" + using divisor_set divisor_def by auto + +lemma union_properdiv_set: assumes "n\1" shows "divisor_set n =(properdiv_set n)\{n}" + using divisor_set properdiv_set proper_divisor_def assms divisor_def by auto + +lemma prime_div_set: assumes "prime n" shows "divisor_set n = {n, 1}" + using divisor_def assms divisor_set prime_nat_iff by auto + +lemma div_set_prime: + assumes "prime n" + shows "properdiv_set n = {1}" + using assms properdiv_set prime_nat_iff proper_divisor_def + by (metis (no_types, lifting) Collect_cong One_nat_def divisor_def divisor_set divisor_set_one + dvd_1_left empty_iff insert_iff mem_Collect_eq order_less_irrefl) + +lemma prime_gcd: fixes m::nat and n::nat assumes "prime m" and "prime n" +and "m \ n" shows "gcd m n =1 " using prime_def + by (simp add: assms primes_coprime) + +text\We refer to definitions from \cite{aliquotwiki}:\ + +definition aliquot_sum :: "nat \ nat" + where "aliquot_sum n \ \(properdiv_set n)" + +definition deficient_number :: "nat \ bool" + where "deficient_number n \ (n > aliquot_sum n)" + +definition abundant_number :: "nat \ bool" + where "abundant_number n \ (n < aliquot_sum n)" + +definition perfect_number :: "nat \ bool" + where "perfect_number n \ (n = aliquot_sum n)" + +lemma example_perfect_6: shows "perfect_number 6" + +proof- + have a: "set(divisors_nat 6) = {1, 2, 3, 6}" by eval + have b: "divisor_set (6) = {1, 2, 3, 6}" + using a def_equiv_divisor_set by simp + have c: "properdiv_set (6) = {1, 2, 3}" + using b union_properdiv_set properdiv_set proper_divisor_def by auto + show ?thesis using aliquot_sum_def c + by (simp add: numeral_3_eq_3 perfect_number_def) +qed + + +subsection\Euler's sigma function and properties\ + +text\The sources of the following useful material on Euler's sigma function are \cite{garciaetal1}, +\cite{garciaetal2}, \cite{sandifer} and \cite{escott}.\ + +definition Esigma :: "nat \ nat" + where "Esigma n \ \(divisor_set n)" + +lemma Esigma_properdiv_set: + assumes "m \ 1" + shows "Esigma m = (aliquot_sum m) + m" + using assms divisor_set properdiv_set proper_divisor_def union_properdiv_set Esigma_def + aliquot_sum_def by fastforce + +lemma Esigmanotzero: + assumes "n \ 1" + shows "Esigma n \ 1" + using Esigma_def assms Esigma_properdiv_set by auto + +lemma prime_sum_div: + assumes "prime n" + shows " Esigma n = n +(1::nat)" +proof - + have "1 \ n" + using assms prime_ge_1_nat by blast + then show ?thesis using Esigma_properdiv_set assms div_set_prime + by (simp add: Esigma_properdiv_set aliquot_sum_def assms div_set_prime) +qed + +lemma sum_div_is_prime: + assumes "Esigma n = n +(1::nat)" and "n \1" + shows "prime n" + +proof (rule ccontr) + assume F: " \ (prime n)" + have " n divisor n" using assms divisor_def by simp + have " (1::nat) divisor n"using assms divisor_def by simp + + have "n \ Suc 0" + using Esigma_def assms(1) by auto + then have r: " \( m::nat). m \ divisor_set n \ m\ (1::nat) \ m \ n" + using assms F + apply (clarsimp simp add: Esigma_def divisor_set divisor_def prime_nat_iff) + by (meson Suc_le_eq dvd_imp_le dvd_pos_nat) + + have "Suc n = \{n,1}" + by (simp add: \n \ Suc 0\) + moreover + have "divisor_set n \ {n,1}" + using assms divisor_set r \1 divisor n\ divisor_set_not_empty by auto + then have "\(divisor_set n) > \{n,1}" + apply (rule sum_strict_mono [OF finite_divisor_set]) + by (simp add: divisor_def divisor_set) + ultimately + show False + using Esigma_def assms(1) by presburger +qed + +lemma Esigma_prime_sum: + fixes k:: nat assumes "prime m" "k \1" + shows "Esigma (m^k) =( m^(k+(1::nat)) -(1::nat)) /(m-1)" + +proof- + have "m > 1" + using \prime m\ prime_gt_1_nat by blast + + have A: " Esigma (m^k) =( \ j= 0..k.( m^j)) " + proof- + have AA: "divisor_set (m^k) = (\j. m ^ j) ` {0..k}" + using assms prime_ge_1_nat + by (auto simp add: power_increasing prime_ge_Suc_0_nat divisor_set divisor_def image_iff + divides_primepow_nat) + + have \
: "\ ((\j. m ^ j) ` {..k}) = sum (\j. m ^ j) {0..k}" for k + proof (induction k) + case (Suc k) + then show ?case + apply (clarsimp simp: atMost_Suc) + by (smt add.commute add_le_same_cancel1 assms(1) atMost_iff finite_atMost finite_imageI +image_iff le_zero_eq power_add power_one_right prime_power_inj sum.insert zero_neq_one) + qed auto + show ?thesis + by (metis "\
" AA Esigma_def atMost_atLeast0) + qed + have B: "(\ i\k.( m^i)) = ( m^Suc k -(1::nat)) /(m-(1::nat))" + + using assms \m > 1\ Set_Interval.geometric_sum [of m "Suc k"] + apply (simp add: ) + by (metis One_nat_def lessThan_Suc_atMost nat_one_le_power of_nat_1 of_nat_diff of_nat_mult +of_nat_power one_le_mult_iff prime_ge_Suc_0_nat sum.lessThan_Suc) + show ?thesis using A B assms + by (metis Suc_eq_plus1 atMost_atLeast0 of_nat_1 of_nat_diff prime_ge_1_nat) +qed + +lemma prime_Esigma_mult: assumes "prime m" and "prime n" and "m \ n" + shows "Esigma (m*n) = (Esigma n)*(Esigma m)" + +proof- + have "m divisor (m*n)" using divisor_def assms + by (simp add: dvd_imp_le prime_gt_0_nat) + moreover have "\(\ k::nat. k divisor (m*n) \ k\(1::nat)\ k \ m \ k \ n \ k\ m*n)" + using assms unfolding divisor_def + by (metis One_nat_def division_decomp nat_mult_1 nat_mult_1_right prime_nat_iff) + ultimately have c: "divisor_set (m*n) = {m, n, m*n, 1}" + using divisor_set assms divisor_def by auto + obtain "m\1" "n\1" + using assms not_prime_1 by blast + then have dd: "Esigma (m*n) = m + n +m *n +1" + using assms by (simp add: Esigma_def c) + then show ?thesis + using prime_sum_div assms by simp +qed + +lemma gcd_Esigma_mult: + assumes "gcd m n = 1" + shows "Esigma (m*n) = (Esigma m)*(Esigma n)" + +proof- + have "Esigma (m*n) = \ {i*j| i j. i \ divisor_set m \ j \ divisor_set n}" + by (simp add: divisor_set_mult Esigma_def) + also have "... = (\i \ divisor_set m. \j \ divisor_set n. i*j)" + proof- + have "inj_on (\(i,j). i*j) (divisor_set m \ divisor_set n)" + using assms + apply (simp add: inj_on_def divisor_set divisor_def) + by (metis assms coprime_dvd_aux mult_left_cancel not_one_le_zero) + moreover have +"{i*j| i j. i \ divisor_set m \ j \ divisor_set n}= (\(i,j). i*j)`(divisor_set m \ divisor_set n)" + by auto + ultimately show ?thesis + by (simp add: sum.cartesian_product sum_image_eq) + qed + also have "... = \( divisor_set m)* \( divisor_set n)" + by (simp add: sum_product) + also have "... = Esigma m * Esigma n" + by (simp add: Esigma_def) + finally show ?thesis . +qed + +lemma deficient_Esigma: + assumes "Esigma m < 2*m" and "m \1" + shows "deficient_number m" + using Esigma_properdiv_set assms deficient_number_def by auto + +lemma abundant_Esigma: + assumes "Esigma m > 2*m" and "m \1" + shows "abundant_number m" + using Esigma_properdiv_set assms abundant_number_def by auto + +lemma perfect_Esigma: + assumes "Esigma m = 2*m" and "m \1" + shows "perfect_number m" + using Esigma_properdiv_set assms perfect_number_def by auto + +subsection\Amicable Numbers; definitions, some lemmas and examples\ + +definition Amicable_pair :: "nat \nat \ bool" (infixr "Amic" 80) + where "m Amic n \ ((m = aliquot_sum n) \ (n = aliquot_sum m)) " + +lemma Amicable_pair_sym: fixes m::nat and n ::nat + assumes "m Amic n " shows "n Amic m " + using Amicable_pair_def assms by blast + +lemma Amicable_pair_equiv_def: + assumes "(m Amic n)" and "m \1" and "n \1" + shows "(Esigma m = Esigma n)\(Esigma m = m+n)" + using assms Amicable_pair_def + by (metis Esigma_properdiv_set add.commute) + +lemma Amicable_pair_equiv_def_conv: + assumes "m\1" and "n\1" and "(Esigma m = Esigma n)\(Esigma m = m+n)" + shows "(m Amic n)" + using assms Amicable_pair_def Esigma_properdiv_set + by (metis add_right_imp_eq add.commute ) + +definition typeAmic :: "nat \ nat \ nat list" + where "typeAmic n m = + [(card {i. \ N. n = N*(gcd n m) \ prime i \ i dvd N \ \ i dvd (gcd n m)}), + (card {j. \ M. m = M*(gcd n m) \ prime j \ j dvd M \ \ j dvd (gcd n m)})]" + +lemma Amicable_pair_deficient: assumes "m > n" and "m Amic n" + shows "deficient_number m" + using assms deficient_number_def Amicable_pair_def by metis + +lemma Amicable_pair_abundant: assumes "m > n" and "m Amic n" + shows "abundant_number n" + using assms abundant_number_def Amicable_pair_def by metis + +lemma even_even_amicable: assumes "m Amic n" and "m \1" and "n \1" and "even m" and "even n" + shows "(2*m \ n)" + +proof( rule ccontr ) + have a: "Esigma m = Esigma n" using \m Amic n\ Amicable_pair_equiv_def Amicable_pair_def + assms by blast + + assume "\ (2*m \ n)" + have "(2*m = n)" using \\ (2*m \ n)\ by simp + have d:"Esigma n = Esigma (2*m)" using \\ (2*m \ n)\ by simp + + then show False + + proof- + have w: "2*m \ divisor_set (2*m)" using divisor_set assms divisor_set_not_empty + by auto + have w1: "2*m \ divisor_set (m)" using divisor_set assms + by (simp add: divisor_def) + have w2: "\ n::nat. n divisor m \ n divisor (2*m)" + using assms divisor_def by auto + have w3: "divisor_set (2*m) \ divisor_set m" using divisor_set divisor_def assms w w1 w2 + by blast + have v: "( \ i \ ( divisor_set (2*m)).i)> ( \ i \ ( divisor_set m).i)" + using w3 sum_strict_mono by (simp add: divisor_def divisor_set) + show ?thesis using v d Esigma_def a by auto + qed +qed + + +subsubsection\Regular Amicable Pairs\ + +definition regularAmicPair :: "nat \ nat \ bool" where + "regularAmicPair n m \ (n Amic m \ + (\M N g. g = gcd m n \ m = M*g \ n = N*g \ squarefree M \ + squarefree N \ gcd g M = 1 \ gcd g N = 1))" + +lemma regularAmicPair_sym: + assumes "regularAmicPair n m" shows "regularAmicPair m n" + +proof- + have "gcd m n = gcd n m" + by (metis (no_types) gcd.commute) + then show ?thesis + using Amicable_pair_sym assms regularAmicPair_def by auto +qed + +definition irregularAmicPair :: "nat \ nat \ bool" where + "irregularAmicPair n m \ (( n Amic m) \ \ regularAmicPair n m)" + +lemma irregularAmicPair_sym: + assumes "irregularAmicPair n m" + shows "irregularAmicPair m n" + using irregularAmicPair_def regularAmicPair_sym Amicable_pair_sym assms by blast + + +subsubsection\Twin Amicable Pairs\ + +text \We refer to the definition in \cite{amicwiki}:\ + +definition twinAmicPair :: "nat \ nat \ bool" where + "twinAmicPair n m \ + (n Amic m) \ (\(\k l. k > Min {n, m} \ k < Max {n, m}\ k Amic l))" + +lemma twinAmicPair_sym: + assumes "twinAmicPair n m" + shows "twinAmicPair m n" + using assms twinAmicPair_def Amicable_pair_sym assms by auto + +subsubsection\Isotopic Amicable Pairs\ + +text\A way of generating an amicable pair from a given amicable pair under certain conditions is +given below. Such amicable pairs are called Isotopic \cite{garciaetal1}.\ + +lemma isotopic_amicable_pair: + fixes m n g h M N :: nat + assumes "m Amic n" and "m \ 1" and "n \ 1"and "m= g*M" and "n = g*N" + and "Esigma h = (h/g) * Esigma g" and "h \ g" and "h > 1" and "g > 1" + and "gcd g M = 1" and "gcd g N = 1" and "gcd h M = 1" and "gcd h N = 1" + shows "(h*M) Amic (h*N)" + +proof- + have a: "Esigma m = Esigma n" using \ m Amic n\ Amicable_pair_equiv_def assms + by blast + have b: "Esigma m = m + n" using \ m Amic n\ Amicable_pair_equiv_def assms + by blast + have c: "Esigma (h*M) = (Esigma h)*(Esigma M)" + + proof- + have "h \ M" + using assms Esigmanotzero gcd_Esigma_mult gcd_nat.idem b mult_eq_self_implies_10 + by (metis less_irrefl) + + show ?thesis using \h \ M\ gcd_Esigma_mult assms + by auto + qed + + have d: "Esigma (g*M) = (Esigma g)*(Esigma M)" + + proof- + have "g\M" using assms gcd_nat.idem by (metis less_irrefl) + show ?thesis using \g\M\ gcd_Esigma_mult assms by auto + qed + + have e: "Esigma (g*N) = (Esigma g)*(Esigma N)" + + proof- + have "g\N" using assms by auto + show ?thesis using \g\N\ gcd_Esigma_mult assms by auto + qed + + have p1: "Esigma m = (Esigma g)*(Esigma M)" using assms d by simp + have p2: "Esigma n = (Esigma g)*(Esigma N)" using assms e by simp + have p3: "Esigma (h*N) = (Esigma h)*(Esigma N)" + + proof- + have "h\N" using assms \ gcd h N =1\ a b p2 by fastforce + show ?thesis using \h \ N\ gcd_Esigma_mult assms by auto + qed + + have A: "Esigma (h*M) = Esigma (h*N)" + using c p3 d e p1 p2 a assms Esigmanotzero by fastforce + + have B: "Esigma (h*M)=(h*M)+(h*N)" + proof- + have s: "Esigma (h*M) = (h/g)*(m+n)" using b c p1 Esigmanotzero assms by simp + have s1: "Esigma (h*M) = h*(m/g+n/g)" using s assms + by (metis add_divide_distrib b of_nat_add semiring_normalization_rules(7) + times_divide_eq_left times_divide_eq_right) + have s2: " Esigma (h*M) = h*(M+N)" + proof- + have v: "m/g = M" using assms by simp + have v1:"n/g = N" using assms by simp + show ?thesis using s1 v v1 assms + using of_nat_eq_iff by fastforce + qed + show ?thesis using s2 assms + by (simp add: add_mult_distrib2) + qed + show ?thesis using Amicable_pair_equiv_def_conv A B assms one_le_mult_iff One_nat_def Suc_leI + by (metis (no_types, hide_lams) nat_less_le) +qed + + +lemma isotopic_pair_example1: + assumes "(3^3*5*11*17*227) Amic (3^3*5*23*37*53)" + shows "(3^2*7*13*11*17*227) Amic (3^2*7*13*23*37*53)" + +proof- + obtain m where o1: "m = (3::nat)^3*5*11*17*227" by simp + obtain n where o2: "n = (3::nat)^3*5*23*37*53" by simp + obtain g where o3: "g = (3::nat)^3*5" by simp + obtain h where o4: "h = (3::nat)^2*7*13" by simp + obtain M where o5: "M = (11::nat)*17*227" by simp + obtain N where o6: "N = (23::nat)*37*53" by simp + have "prime(3::nat)" by simp + have "prime(5::nat)" by simp + have "prime(7::nat)" by simp + have "prime(13::nat)" by simp + + have v: "m Amic n" using o1 o2 assms by simp + have v1: "m = g*M" using o1 o3 o5 by simp + have v2: "n = g*N" using o2 o3 o6 by simp + have v3: "h >0" using o4 by simp + have w: "g >0" using o3 by simp + have w1: "h \ g" using o4 o3 by simp + have "h = 819" using o4 by simp + have "g = 135" using o3 by simp + + have w2: "Esigma h = (h/g)*Esigma g" + + proof- + have B: "Esigma h = 1456" + proof- + have R: "set(divisors_nat 819) ={1, 3, 7, 9, 13, 21, 39, 63, 91, 117, 273, 819}" + by eval + have RR: "set( divisors_nat(819)) = divisor_set (819)" + using def_equiv_divisor_set by simp + + show?thesis using Esigma_def RR R \ h = 819\ divisor_def divisors_nat divisors_nat_def by auto + qed + + have C: "Esigma g = 240" + proof- + have G: "set(divisors_nat 135) = {1, 3, 5, 9, 15, 27, 45, 135}" + by eval + have GG: "set(divisors_nat 135) = divisor_set 135" + using def_equiv_divisor_set by simp + + show ?thesis using G GG Esigma_def \ g = 135\ + properdiv_set proper_divisor_def + by simp + qed + have D: "(Esigma h) * g = (Esigma g) * h" + + proof- + have A: "(Esigma h) * g = 196560" + using B o3 by simp + have AA: "(Esigma g) * h = 196560" using C o4 by simp + show ?thesis using A AA by simp + qed + show ?thesis using D + by (metis mult.commute nat_neq_iff nonzero_mult_div_cancel_right +of_nat_eq_0_iff of_nat_mult times_divide_eq_left w) + + qed + + have w4: "gcd g M =1" + + proof- + have "coprime g M" + + proof- + have "\ g dvd M" using o3 o5 by auto + moreover have "\ 3 dvd M" using o5 by auto + moreover have "\ 5 dvd M" using o5 by auto + ultimately show ?thesis using o5 o3 + gcd_nat.absorb_iff2 prime_nat_iff \ prime(3::nat)\ \ prime(5::nat)\ + by (metis coprime_commute +coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat) +qed + show ?thesis using \coprime g M\ by simp + qed + + have s: " gcd g N =1" + + proof- + have "coprime g N" + + proof- + have "\ g dvd N" + using o3 o6 by auto + moreover have "\ 3 dvd N" using o6 by auto + moreover have "\ 5 dvd N" using o6 by auto + ultimately show ?thesis using o3 gcd_nat.absorb_iff2 prime_nat_iff \ prime(3::nat)\ + \ prime(5::nat)\ + by (metis coprime_commute +coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat) +qed + show ?thesis using \coprime g N\ by simp + qed + + have s1: "gcd h M =1" + + proof- + have "coprime h M" + + proof- + have "\ h dvd M" using o4 o5 by auto + moreover have "\ 3 dvd M" using o5 by auto + moreover have "\ 7 dvd M" using o5 by auto + moreover have "\ 13 dvd M" using o5 by auto + ultimately show ?thesis using o4 gcd_nat.absorb_iff2 prime_nat_iff \ prime(3::nat)\ +\ prime(13::nat)\ \ prime(7::nat)\ + + by (metis coprime_commute +coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat) +qed + + show ?thesis using \coprime h M\ by simp + qed + + have s2: "gcd h N =1" + + proof- + have "coprime h N" + + proof- + have "\ h dvd N" using o4 o6 by auto + moreover have "\ 3 dvd N" using o6 by auto + moreover have "\ 7 dvd N" using o6 by auto + moreover have "\ 13 dvd N" using o6 by auto + ultimately show ?thesis using o4 + gcd_nat.absorb_iff2 prime_nat_iff \ prime(3::nat)\\ prime(13::nat)\ \ prime(7::nat)\ + + by (metis coprime_commute +coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat) +qed + + show ?thesis using \coprime h N\ by simp + qed + + have s4: "(h*M) Amic (h*N)" using isotopic_amicable_pair v v1 v2 v3 w4 s s1 s2 w w1 w2 + by (metis One_nat_def Suc_leI le_eq_less_or_eq nat_1_eq_mult_iff +num.distinct(3) numeral_eq_one_iff one_le_mult_iff one_le_numeral o3 o4 o5 o6) + + show ?thesis using s4 o4 o5 o6 by simp +qed + + +subsubsection\Betrothed (Quasi-Amicable) Pairs\ + +text\We refer to the definition in \cite{betrothedwiki}:\ + +definition QuasiAmicable_pair :: "nat \ nat \ bool" (infixr "QAmic" 80) + where "m QAmic n \ (m + 1 = aliquot_sum n) \ (n + 1 = aliquot_sum m)" + +lemma QuasiAmicable_pair_sym : + assumes "m QAmic n " shows "n QAmic m " + using QuasiAmicable_pair_def assms by blast + +lemma QuasiAmicable_example: + shows "48 QAmic 75" + +proof- + have a: "set(divisors_nat 48) = {1, 2, 3, 4, 6, 8, 12, 16, 24, 48}" by eval + have b: "divisor_set (48) = {1, 2, 3, 4, 6, 8, 12, 16, 24, 48}" + using a def_equiv_divisor_set by simp + have c: "properdiv_set (48) = {1, 2, 3, 4, 6, 8, 12, 16, 24}" + using b union_properdiv_set properdiv_set proper_divisor_def by auto + have e: "aliquot_sum (48) = 75+1" using aliquot_sum_def c + by simp + have i: "set(divisors_nat 75) = {1, 3, 5, 15, 25, 75}" by eval + have ii: "divisor_set (75) = {1, 3, 5, 15, 25, 75}" + using i def_equiv_divisor_set by simp + have iii: "properdiv_set (75) = {1, 3, 5, 15, 25}" + using ii union_properdiv_set properdiv_set proper_divisor_def by auto + have iv: "aliquot_sum (75) = 48+1" using aliquot_sum_def iii + by simp + show ?thesis using e iv QuasiAmicable_pair_def by simp +qed + + +subsubsection\Breeders\ + +definition breeder_pair :: "nat \nat \ bool" (infixr "breeder" 80) + where "m breeder n \ (\x\\. x > 0 \ Esigma m = m + n*x \ Esigma m = (Esigma n)*(x+1))" + +lemma breederAmic: + fixes x :: nat + assumes "x > 0" and "Esigma n = n + m*x" and "Esigma n = Esigma m * (x+1)" + and "prime x" and "\( x dvd m)" + shows " n Amic (m*x)" + +proof- + have A: "Esigma n = Esigma (m*x)" + proof- + have "gcd m x =1" using assms gcd_nat.absorb_iff2 prime_nat_iff by blast + + have A1: "Esigma (m*x) = (Esigma m)*(Esigma x)" + using \gcd m x =1\ gcd_Esigma_mult by simp + have A2: "Esigma (m*x) = (Esigma m)*(x+1)" + using \prime x\ prime_Esigma_mult A1 + by (simp add: prime_sum_div) + show ?thesis using A2 assms by simp + qed + + have B: "Esigma n = n+m*x" using assms by simp + show ?thesis using A B Amicable_pair_equiv_def + by (smt Amicable_pair_equiv_def_conv Esigma_properdiv_set +One_nat_def Suc_leI add_cancel_left_left add_le_same_cancel1 add_mult_distrib2 assms + dvd_triv_right le_add2 nat_0_less_mult_iff not_gr_zero not_le semiring_normalization_rules(1)) + qed + + +subsubsection\More examples\ + +text\The first odd-odd amicable pair was discovered by Euler \cite{garciaetal1}. In the following +proof, amicability is shown using the properties of Euler's sigma function.\ + +lemma odd_odd_amicable_Euler: "69615 Amic 87633" +proof- + have "prime(5::nat)" by simp + have "prime(17::nat)" by simp + have "\ (5*17)dvd((3::nat)^2*7*13)" by auto + have "\ 5 dvd((3::nat)^2*7*13)" by auto + have "\ 17 dvd((3::nat)^2*7*13)" by auto + have A1: "Esigma(69615) = Esigma(3^2*7*13*5*17)" by simp + have A2: "Esigma(3^2*7*13*5*17) = Esigma(3^2*7*13)*Esigma(5*17)" + + proof- + have A111: "coprime ((3::nat)^2*7*13) ((5::nat)*17)" + using \\ 17 dvd((3::nat)^2*7*13)\ \\ 5 dvd((3::nat)^2*7*13)\ \prime (17::nat)\ + \prime (5::nat)\ coprime_commute coprime_mult_left_iff prime_imp_coprime_nat by blast + + have "gcd (3^2*7*13)((5::nat)*17) =1" + using A111 coprime_imp_gcd_eq_1 by blast + show ?thesis using \gcd (3^2*7*13)((5::nat)*17) =1 \ + gcd_Esigma_mult + by (smt semiring_normalization_rules(18) semiring_normalization_rules(7)) + qed + have "prime (7::nat)" by simp + have "\ 7 dvd ((3::nat)^2)" by simp + have "prime (13::nat)" by simp + have " \ 13 dvd ((3::nat)^2*7)" by simp + have "gcd ((3::nat)^2*7) 13 =1" + using \prime (13::nat)\ \\ 13 dvd ((3::nat)^2*7)\ gcd_nat.absorb_iff2 prime_nat_iff + by blast + have A3: " Esigma(3^2 * 7*13) = Esigma(3^2*7)*Esigma(13)" + using \gcd (3^2 *7) 13 =1\ gcd_Esigma_mult + by (smt semiring_normalization_rules(18) semiring_normalization_rules(7)) + have "gcd ((3::nat)^2) 7 = 1" + using \prime (7::nat)\ \ \ 7 dvd ((3::nat)^2 )\ gcd_nat.absorb_iff2 prime_nat_iff + by blast + have A4: " Esigma(3^2*7) = Esigma(3^2)* Esigma (7)" + using \gcd ((3::nat)^2) 7 =1\ gcd_Esigma_mult + by (smt semiring_normalization_rules(18) semiring_normalization_rules(7)) + have A5: "Esigma(3^2) = 13" + proof- + have "(3::nat)^2 =9" by auto + have A55:"divisor_set 9 = {1, 3, 9}" + proof- + have A555: "set(divisors_nat (9)) = {1, 3, 9}" by eval + show ?thesis using def_equiv_divisor_set A555 by simp + qed + show ?thesis using A55 \(3::nat)^2 =9\ Esigma_def by simp + qed + have "prime( 13::nat)" by simp + have A6: "Esigma (13) = 14" + using prime_sum_div \prime( 13::nat)\ by auto + have "prime( 7::nat)" by simp + have A7: "Esigma (7) = 8" + using prime_sum_div \prime( 7::nat)\ by auto + have "prime (5::nat)" by simp + have "prime (17::nat)" by simp + have A8: "Esigma(5*17) = Esigma(5) * Esigma (17)" + using prime_Esigma_mult \prime (5::nat)\ \prime (17::nat)\ + by (metis arith_simps(2) mult.commute num.inject(2) numeral_eq_iff semiring_norm(83)) + have A9: "Esigma(69615) = Esigma(3^2)*Esigma (7) *Esigma (13) * Esigma(5) * Esigma (17)" + using A1 A2 A3 A4 A5 A6 A7 A8 by (metis mult.assoc) + have A10: "Esigma (5)=6" + using prime_sum_div \prime(5::nat)\ by auto + have A11: "Esigma (17)=18" + using prime_sum_div \prime(17::nat)\ by auto + have AA: "Esigma(69615)=13*8*14*6*18" using A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 + by simp + have AAA: "Esigma(69615) =157248" using AA by simp + + have AA1: "Esigma(87633) = Esigma (3^2*7*13*107)" by simp + have "prime (107::nat)" by simp + have AA2: "Esigma (3^2*7*13*107) = Esigma (3^2*7*13)*Esigma(107)" + + proof- + have "\ (107::nat) dvd (3^2*7*13)" by auto + have "gcd ((3::nat)^2*7*13) 107 =1" using \prime (107::nat)\ + \ \ (107::nat) dvd (3^2*7*13)\ + + using gcd_nat.absorb_iff2 prime_nat_iff by blast + + show ?thesis using \gcd (3^2 *7*13) 107 =1\ gcd_Esigma_mult by (smt mult.commute) + qed + have AA3: "Esigma (107) =108" + using prime_sum_div \prime(107::nat)\ by auto + have AA4: "Esigma(3^2*7*13) = 13*8*14" + using A3 A4 A5 A6 A7 by auto + have AA5 : "Esigma (3^2*7*13*107) = 13*8*14*108" + using AA2 AA3 AA4 by auto + have AA6: "Esigma (3^2*7*13*107) = 157248" using AA5 by simp + have A:"Esigma(69615) = Esigma(87633)" + using AAA AA6 AA5 AA1 by linarith + have B: " Esigma(87633) = 69615 + 87633" + using AAA \Esigma 69615 = Esigma 87633\ by linarith + show ?thesis using A B Amicable_pair_def Amicable_pair_equiv_def_conv by auto +qed + +text\The following is the smallest odd-odd amicable pair \cite{garciaetal1}. In the following proof, +amicability is shown directly by evaluating the sets of divisors.\ + +lemma Amicable_pair_example_smallest_odd_odd: "12285 Amic 14595" +proof- + have A: "set(divisors_nat (12285)) = {1, 3, 5, 7, 9, 13, 15, 21, 27, 35, 39, 45, 63, 65, 91, +105, 117, 135, 189, 195, 273, 315, 351, 455, 585, 819, 945, 1365, 1755, 2457, 4095, 12285}" + by eval + have A1: "set(divisors_nat (12285)) = divisor_set 12285" + using def_equiv_divisor_set by simp + have A2: "\{1, 3, 5, 7, 9, 13, 15, 21, 27, 35, 39, 45, 63, 65, 91, 105, 117, 135, 189, 195, 273, +315, 351, 455, 585, 819, 945, 1365, 1755, 2457, 4095, 12285} = (26880::nat)" by eval + have A3: "Esigma 12285 = 26880" using A A1 A2 Esigma_def by simp + have Q:"Esigma 12285 = Esigma 14595" + proof- + have N: "set(divisors_nat (14595)) = + { 1, 3, 5, 7, 15, 21, 35, 105, 139, 417, 695, 973, 2085, 2919, 4865, 14595}" + by eval + have N1: "set(divisors_nat (14595)) = divisor_set 14595" + using def_equiv_divisor_set by simp + have N2: + "\{ 1, 3, 5, 7, 15, 21, 35, 105, 139, 417, 695, 973, 2085, 2919, 4865, 14595} = (26880::nat)" + by eval + show ?thesis using A3 N N1 N2 Esigma_def by simp + qed + have B:"Esigma (12285) = 12285 + 14595" using A3 by auto + show ?thesis using B Q Amicable_pair_def + using Amicable_pair_equiv_def_conv one_le_numeral by blast +qed + + +section\Euler's Rule\ + +text\We present Euler's Rule as in \cite{garciaetal1}. The proof has been reconstructed.\ + +theorem Euler_Rule_Amicable: + fixes k l f p q r m n :: nat + assumes "k > l" and "l \ 1" and "f = 2^l+1" + and "prime p" and "prime q" and "prime r" + and "p = 2^(k-l) * f - 1" and "q = 2^k * f - 1" and "r = 2^(2*k-l) * f^2 - 1" + and "m = 2^k * p * q" and "n = 2^k * r" + shows "m Amic n" + +proof- + note [[linarith_split_limit = 50]] + have A1: "(p+1)*(q+1) = (r+1)" + proof- + have a: "p+1 = (2^(k-l))*f" using assms by simp + have b: "q+1 = (2^(k))*f" using assms by simp + have c: "r+1 = (2^(2*k-l))*(f^2)" using assms by simp + have d: "(p+1)*(q+1) = (2^(k-l))*(2^(k))*f^2" + using a b by (simp add: power2_eq_square) + show ?thesis using d c + by (metis Nat.add_diff_assoc add.commute assms(1) less_imp_le_nat mult_2 power_add) + qed + have aa: "Esigma p = p+1" using assms \prime p\ prime_sum_div by simp + have bb: "Esigma q = q+1" using \prime q\ prime_sum_div assms by simp + have cc: "Esigma r = r+1" using \prime r\ prime_sum_div assms by simp + have A2: "(Esigma p)*(Esigma q) = Esigma r" + using aa bb cc A1 by simp + have A3: "Esigma (2^k)*(Esigma p)*(Esigma q) = Esigma(2^k)*(Esigma r)" + using A2 by simp + have A4: "Esigma(( 2^k)*r) = (Esigma(2^k))*(Esigma r)" + proof- + have Z0: "gcd ((2::nat)^k)r =1" using assms \prime r\ by simp + have A: "(2::nat)^k \ 1" using assms by simp + have Ab: "(2::nat)^k \ r" using assms + by (metis gcd_nat.idem numeral_le_one_iff prime_ge_2_nat semiring_norm(69) Z0) + show ?thesis using Z0 gcd_Esigma_mult assms A Ab by metis + qed + + have A5: "Esigma((2^k)*p*q) =(Esigma(2^k))*(Esigma p)*(Esigma q)" + proof- + have "(2::nat)^k \1" using assms by simp + have A: "gcd (2^k) p =1" using assms \prime p\ by simp + have B: "gcd (2^k) q =1" using assms \prime q\ by simp + have BB: "gcd (2^k) (p*q) =1" using assms A B by fastforce + have C: "p*q \1" using assms One_nat_def one_le_mult_iff prime_ge_1_nat by metis + have A6: " Esigma((2^k)*(p*q))=( Esigma(2^k))*(Esigma(p*q))" + proof- + have "(( 2::nat)^k) \ (p*q)" using assms + by (metis BB Nat.add_0_right gcd_idem_nat less_add_eq_less + not_add_less1 power_inject_exp prime_gt_1_nat semiring_normalization_rules(32) + two_is_prime_nat ) + show ?thesis using \(( 2::nat)^k) \ (p*q)\ + \( 2::nat)^k \1\ gcd_Esigma_mult assms C BB + by metis + qed + have A7:"Esigma(p*q) = (Esigma p)*(Esigma q)" + proof- + have "p \ q" using assms One_nat_def Suc_pred add_gr_0 add_is_0 diff_commute diff_diff_cancel + diff_is_0_eq nat_0_less_mult_iff nat_mult_eq_cancel_disj + numeral_One prime_gt_1_nat power_inject_exp + semiring_normalization_rules(7) two_is_prime_nat zero_less_numeral zero_less_power +zero_neq_numeral by (smt less_imp_le_nat) + + show ?thesis using \p \ q\ + \prime p\ \prime q\ C prime_Esigma_mult assms + by (metis mult.commute) + qed + + have A8: "Esigma((2^k)*( p*q))=(Esigma(2^k))*(Esigma p)*(Esigma q)" by (simp add: A6 A7) + show ?thesis using A8 by (simp add: mult.assoc) + qed + + have Z: "Esigma((2^k)*p*q) = Esigma ((2^k)*r)" using A1 A2 A3 A4 A5 by simp + + have Z1: "Esigma ((2^k)*p*q) = 2^k *p*q + 2^k*r" + + proof- + have "prime (2::nat)" by simp + have s: "Esigma (2^k) =((2::nat)^(k+1)-1)/(2-1)" + using \prime (2::nat)\ assms Esigma_prime_sum by auto + have ss: "Esigma (2^k) =(2^(k+1)-1)" using s by simp + have J: "(k+1+k-l+k)= 3*k +1-l" using assms by linarith + have JJ: "(2^(k-l))*(2^k) = (2::nat)^(2*k-l)" + apply (simp add: algebra_simps) + by (metis Nat.add_diff_assoc assms(1) less_imp_le_nat mult_2_right power_add) + have "Esigma((2^k)*p*q)= (Esigma(2^k))*(Esigma p)*(Esigma q)" using A5 by simp + also have "\ = (2^(k+1)-1)*(p+1)*(q+1)" using assms ss aa bb by metis + also have "\ = (2^(k+1)-1)*((2^(k-l))*f)*((2^k)*f)" using assms by simp + also have "\ = (2^(k+1)-1)*(2^(k-l))*(2^k)*f^2" + by (simp add: power2_eq_square) + also have "\ = (2^(k+1))*(2^(k-l))*(2^k)*f^2-(2^(k-l))*(2^k)*f^2" + by (smt left_diff_distrib' mult.commute mult_numeral_1_right numeral_One) + also have "\ = (2^(k+1+k-l+k))*f^2-(2^(k-l))*(2^k)*f^2" + by (metis Nat.add_diff_assoc assms(1) less_imp_le_nat power_add) + also have "\ = (2^(3*k+1-l))*f^2-(2^(k-l))*(2^k)*f^2" + using J by auto + also have "\ = (2^(3*k+1-l))*f^2-(2^(2*k-l))*f^2" + using JJ by simp + finally + have YY:" Esigma((2^k)*p*q)= (2^(3*k+1-l))*f^2-(2^(2*k-l))*f^2" . + + have auxicalc: "(2^(2*k-l))*(f^2)=(2^(2*k-l))*f +(2^(2*k))*f" + + proof- + have i: "(2^(2*k-l))*f = (2^(2*k-l))*(2^l+1)" + using assms \f = 2^l+1\ by simp + have ii: "( 2^(2*k-l))*f = (2^(2*k-l))*( 2^l)+(2^(2*k-l))" + using i by simp + have iii: "(2^(2*k-l))*f = (2^(2*k-l+l))+(2^(2*k-l))" + using ii by (simp add: power_add) + have iv: "( 2^(2*k-l))*f*f =(((2^(2*k))+(2^(2*k-l))))*f" + using iii assms by simp + have v: "(2^(2*k-l))*f *f =((2^(2*k)))*f+((2^(2*k-l)))*f" + using iv assms comm_monoid_mult_axioms power2_eq_square semiring_normalization_rules(18) + semiring_normalization_rules by (simp add: add_mult_distrib assms) (*slow*) + show ?thesis using v by (simp add: power2_eq_square semiring_normalization_rules(18)) + qed + + have W1: "2^k*p*q + 2^k*r = 2^k *(p*q +r) " + by (simp add: add_mult_distrib2) + + have W2: "2^k*(p*q +r)= 2^k *((2^(k-l)*f-1)*((2^k)*f-1)+(2^(2*k-l))*f^2-1)" + using assms by simp + + have W3: "2^k*((2^(k-l)*f-1)*((2^k)*f-1)+(2^(2*k-l))*f^2-1)= +2^k*((2^(k-l)*f-1)*((2^k)*f)-(2^(k-l)*f-1)+(2^(2*k-l))*f^2-1)" + by (simp add: right_diff_distrib') + + have W4: "2^k*((2^(k-l)*f-1)*((2^k)*f)-(2^(k-l)*f-1)+(2^(2*k-l))*f^2-1) = +2^k*((2^(k-l)*f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f-1)+(2^(2*k-l))*f^2-1)" + using assms by (simp add: diff_mult_distrib) + + have W5: " 2^k*((2^(k-l)*f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f-1)+(2^(2*k-l))*f^2-1) = +2^k *(( 2^(k-l)*f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f)+1 +(2^(2*k-l))*f^2-1)" + using assms less_imp_le_nat less_imp_le_nat prime_ge_1_nat + by (smt Nat.add_diff_assoc2 Nat.diff_diff_right One_nat_def Suc_leI Suc_pred W3 W4 + add_diff_cancel_right' add_gr_0 le_Suc_ex less_numeral_extra(1) mult_cancel1 + nat_0_less_mult_iff zero_less_diff zero_less_numeral zero_less_power) + + have W6: "2^k*((2^(k-l)* f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f)+1+(2^(2*k-l))*f^2-1 ) = + 2^k*((2^(k-l)*f)*((2^k)*f)-((2^k )*f)-(2^(k-l)*f)+(2^(2*k-l))*f^2)" + by simp + + have W7: "2^k*((2^(k-l)*f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f)+(2^(2*k-l))*f^2) = + 2^k *((2^(2*k-l+1)*(f^2))-((2^k)*f)-(2^(k-l)* f))" + + proof- + have a: "(2^(k-l)*f)*(2^k * f) = (2^(k-l)*f*(f*(2^k))) " + using assms by simp + have b: "(2^(k-l)*f)*(f*(2^k)) = 2^(k-l)*(f*f)*(2^k)" + using assms by linarith + have c: "2^(k-l)*(f*f)*(2^k) = 2^(k-l+k)*(f^2)" + using Semiring_Normalization.comm_semiring_1_class.semiring_normalization_rules(16) + Semiring_Normalization.comm_semiring_1_class.semiring_normalization_rules(29) + by (simp add: power_add) + + have d: "2^(k-l+k) *(f^2) = 2^(2*k-l) *(f^2)" + by (simp add: JJ power_add) + + have e: "(2^(2*k-l))*f^2 + (2^(2*k-l))*f^2 = 2^(2*k-l +1)*(f^2)" + by simp + + have f1: "((2^(k-l)*f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f)+(2^(2*k-l))*f^2) = + (2^(2*k-l)*(f^2)-((2^k)*f)-(2^(k-l)*f)+(2^(2*k-l))*f^2)" + using a b c d e by simp + + have f2:"((2^(k-l)*f)*((2^k)*f)-((2^k)*f)-(2^(k-l)*f))+(2^(2*k-l))*f^2 + = ((2^(2*k-l+1)*(f^2))-((2^k)*f)-(2^(k-l)*f))" + + proof- + have aa: "f > 1" using assms by simp + have a: "((2::nat)^(2*k-l))*f^2-((2::nat)^(k-l)*f)>0" + proof- + have b: "(2::nat)^(2*k-l) > 2^(k-l)" using assms by simp + have c: "(2::nat)^(2*k-l)*f > 2^(k-l)*f" using a assms + by (metis One_nat_def add_gr_0 b lessI mult_less_mono1) + show ?thesis + using c auxicalc by linarith + qed + + have aaa: "(2^(2*k-l))*f^2 -(2^(k-l)*f)-((2^k)*f) >0" + + proof- + have A: "(2^(2*k-l))*f-(2^(k-l))-(( 2^k)) >0" + + proof- + have A_1 : "(2^(2*k-l))*f > (2^(k-l))+((2^k))" + + proof- + have A_2: "(2^(2*k-l))*f = 2^(k)*2^(k-l)*f" + by (metis JJ semiring_normalization_rules(7)) + + have df1: "(2^(k-l))+((2^k))< ((2::nat)^(2*k-l))+((2^k))" + using \l < k\ by (simp add: algebra_simps) + + have df2: "((2::nat)^(2*k-l))+((2^k)) < ((2::nat)^(2*k-l))*f" + proof- + have "k >1" using assms by simp + have df: "((2::nat)^(k-l))+(1::nat) < ((2::nat)^(k-l))*f" + proof- + obtain x::nat where xx: "x=(2::nat)^(k-l)" by simp + have xxx: "x \( 2::nat)" using assms xx + by (metis One_nat_def Suc_leI one_le_numeral power_increasing + semiring_normalization_rules(33) zero_less_diff) + + have c: "x*f \ x*(2::nat)" using aa by simp + + have c1: "x+(1::nat) < x*(2::nat)" + using auxiliary_ineq xxx by linarith + have c2: "((2::nat)^(k-l))+(1::nat) < ((2::nat)^(k-l))*(2::nat)" + using c1 xx by blast + show ?thesis using c2 c xx + by (metis diff_is_0_eq' le_trans nat_less_le zero_less_diff) + qed + + show ?thesis using df aa assms + by (smt JJ add.commute mult_less_cancel2 semiring_normalization_rules + zero_less_numeral zero_less_power) + qed + show ?thesis using A_2 df1 df2 by linarith + qed + + show ?thesis using assms A_1 + using diff_diff_left zero_less_diff by presburger + qed + + show ?thesis using A aa assms + by (metis (no_types, hide_lams) a nat_0_less_mult_iff right_diff_distrib' + semiring_normalization_rules(18) semiring_normalization_rules(29) + semiring_normalization_rules(7)) + qed + + have b3: "((2^(2*k-l)*(f^2))-((2^k)*f)-(2^(k-l)*f)+(2^(2*k-l))*f^2) = + (2*(2^(2*k-l)*(f^2))-((2^k)*f)-(2^(k-l)*f))" + using a aa assms minus_eq_nat_subst_order by (smt aaa diff_commute) + + show ?thesis using f1 by (metis b3 e mult_2) + + qed + show ?thesis using f2 by simp + qed + + have W8: "2^k*((2^(2*k-l+1)*(f^2))-((2^k)*f)-(2^(k-l)*f)) = (2^(3*k+1-l))*f^2-(2^(2*k-l))*f^2" + + proof- + have a: "2^k*(2^(2*k-l+1)*f^2-2^k*f-2^(k-l)*f) = 2^k*(2^(2*k-l+1)*f^2)-2^k*(2^k*f)-2^k*(2^(k-l)*f)" + by (simp add: algebra_simps) + + have b: "2^k*(2^(2*k-l+1)*f^2)-2^k*(2^k*f)-2^k*(2^(k-l)*f) = +2^k*(2^(2*k-l+1)*f^2)-2^k*(2^k*f)-2^k*(2^(k-l)*f)" + by (simp add: algebra_simps) + + have c: "2^k*(2^(2*k-l+1)*f^2)-2^k*(2^k*f)-2^k*(2^(k-l)*f) = +2^(2*k+1-l+k)*f^2-2^k*(2^k*f)-2^k*(2^(k-l)*f)" + apply (simp add: algebra_simps power_add) + by (smt Groups.mult_ac(1) Groups.mult_ac(2) Nat.diff_add_assoc assms(1) le_simps(1) +mult_2_right plus_nat.simps(2) power.simps(2)) + + have d: "2^k*(2^(2*k-l+1)*(f^2))= (2^(3*k+1-l))*f^2" + + using power_add Nat.add_diff_assoc assms(1) less_imp_le_nat mult_2 + semiring_normalization_rules(18) semiring_normalization_rules(23) + by (smt J) + + have e: "2^k*((2^(2*k-l+1)*(f^2))-((2^k)*f)-(2^(k-l)*f)) = +(2^(3*k+1-l))*f^2-(2^k)*((2^k)*f)-(2^k)*(2^(k-l)*f)" + + using a b c d One_nat_def one_le_mult_iff + Nat.add_diff_assoc assms(1) less_imp_le_nat by metis + + have ee: "2^k*((2^(2*k-l+1)*(f^2))-((2^k)*f)-((2::nat)^(k-l)*f)) += (2^(3*k+1-l))*f^2-( 2^k)*((2^k)*f)-(2^(2*k-l)*f)" + + using e power_add Nat.add_diff_assoc assms(1) less_imp_le_nat mult_2 + semiring_normalization_rules + by (smt J) + + have eee : + "-(( 2::nat)^(2*k-l))*(f^(2::nat)) =(-(( 2::nat)^(2*k))*f-(( 2::nat)^(2*k-l))*f)" + using auxicalc mult_minus_eq_nat mult_minus_left of_nat_mult by smt + + have e4: "2^k*((2^(2*k-l+1)*(f^2))-((2^k)*f)-(2^(k-l)*f))=(2^(3*k+1-l))*f^2-(2^(2*k-l))*(f^2)" + + proof- + define A where A: "A = 2^k*((2^(2*k-l+1)*(f^2))-((2^k)*f)-(2^(k-l)*f))" + define B where B: "B = (2^(3*k+(1::nat)-l))*f^2" + define C where C: "C = (2^k)*((2^k)*f)" + define D where D: "D = (2^(2*k-l)*f)" + define E where E: "E = (2^(2*k-l))*(f^2)" + have wq: "A = B-C-D" using ee A B C D by simp + have wq1: "-E = -C-D" using eee C D E + by (simp add: semiring_normalization_rules(36)) + have wq2: "A = B-E" using wq wq1 minus_eq_nat_subst by blast + show ?thesis using wq2 A B E + by metis + qed + show ?thesis using e4 by simp + qed + + have Y: "2^k*p*q+2^k*r = (2^(3*k+1-l))*f^2-(2^(2*k-l))*f^2" + using W1 W2 W3 W4 W5 W6 W7 W8 by linarith + show ?thesis using Y YY auxicalc by simp + qed + + show ?thesis using Z Z1 Amicable_pair_equiv_def_conv assms One_nat_def one_le_mult_iff + one_le_numeral less_imp_le_nat one_le_power + by (metis prime_ge_1_nat) +qed + +text\Another approach by Euler \cite{garciaetal1}:\ + +theorem Euler_Rule_Amicable_1: + fixes m n a :: nat + assumes "m \ 1" and "n \ 1" and "a \ 1" + and "Esigma m = Esigma n" and "Esigma a * Esigma m = a*(m+n)" + and "gcd a m =1" and "gcd a n =1" + shows "(a*m) Amic (a*n)" + +proof- + have a: "Esigma (a*m) =(Esigma a)*(Esigma m)" + using assms gcd_Esigma_mult by (simp add: mult.commute) + + have b: "Esigma (a*m) = Esigma (a*n)" + + proof- + have c: "Esigma (a*n) = (Esigma a)*(Esigma n)" + using gcd_Esigma_mult \gcd a n =1\ + by (metis assms(4) a ) + show ?thesis using c a assms by simp + qed + + have d: " Esigma (a*m) = a*m + a*n " + using a assms by (simp add: add_mult_distrib2) + show ?thesis using a b d Amicable_pair_equiv_def_conv assms by (simp add: Suc_leI) +qed + + +section\Th\={a}bit ibn Qurra's Rule and more examples\ + +text\Euler's Rule (theorem Euler\_Rule\_Amicable) is actually a generalisation of the following +rule by Th\={a}bit ibn Qurra from the 9th century \cite{garciaetal1}. Th\={a}bit ibn Qurra's Rule is +the special case for $l=1$ thus $f=3$.\ + +corollary Thabit_ibn_Qurra_Rule_Amicable: + fixes k l f p q r :: nat + assumes "k > 1" and "prime p" and "prime q" and "prime r" + and "p = 2^(k-1) * 3 - 1" and "q = 2^k * 3 - 1" and "r = 2^(2*k-1) * 9 - 1" + shows "((2^k)*p*q) Amic ((2^k)*r)" + +proof- + obtain l where l:"l = (1::nat)" by simp + obtain f where f:"f = (3::nat)" by simp + have "k >l" using l assms by simp +have "f =2^1+1" using f by simp +have " r =(2^(2*k-1))*(3^2)-1" using assms by simp + show ?thesis using assms Euler_Rule_Amicable \f =2^1 +1\ + \ r =(2^(2*k -1))*(3^2) -1\ l f + by (metis le_numeral_extra(4)) +qed + +text\In the following three example of amicable pairs, instead of evaluating the sum of the divisors +or using the properties of Euler's sigma function as it was done in the previous examples, we +prove amicability more directly as we can apply Th\={a}bit ibn Qurra's Rule.\ + +text\The following is the first example of an amicable pair known to the Pythagoreans and can be +derived from Th\={a}bit ibn Qurra's Rule with $k=2$ \cite{garciaetal1}.\ + +lemma Amicable_Example_Pythagoras: + shows "220 Amic 284" + +proof- + have a: "(2::nat)>1" by simp + have b: "prime((3::nat)*(2^(2-1))-1)" by simp + have c: "prime((3::nat)*(2^2)-1)" by simp + have d: "prime((9::nat)*(2^(2*2-1))-1)" by simp + have e: "((2^2)*(3*(2^(2-1))-1)*(3*(2^2)-1))Amic((2^2)*(9*(2^(2*2-1))-1))" + using Thabit_ibn_Qurra_Rule_Amicable a b c d + by (metis mult.commute) + + have f: "((2::nat)^2)*5*11 = 220" by simp + have g: "((2::nat)^2)*71 = 284" by simp + show ?thesis using e f g by simp +qed + +text\The following example of an amicable pair was (re)discovered by Fermat and can be derived from +Th\={a}bit ibn Qurra's Rule with $k=4$ \cite{garciaetal1}.\ + +lemma Amicable_Example_Fermat: + shows "17296 Amic 18416" + +proof- + have a: "(4::nat)>1" by simp + have b: "prime((3::nat)*(2^(4-1))-1)" by simp + have c: "prime((3::nat)*(2^4)-1)" by simp + have d: "prime (1151::nat)" by (pratt (code)) + have e: "(1151::nat) = 9*(2^(2*4-1))-1" by simp + have f: "prime((9::nat)*(2^(2*4-1))-1)" using d e by metis + have g: "((2^4)*(3*(2^(4-1))-1)*(3*(2^4)-1)) Amic((2^4)*(9*(2^(2*4-1))-1))" + using Thabit_ibn_Qurra_Rule_Amicable a b c f by (metis mult.commute) + have h: "((2::nat)^4)*23*47 = 17296" by simp + have i: "(((2::nat)^4)*1151) = 18416" by simp + + show ?thesis using g h i by simp +qed + +text\The following example of an amicable pair was (re)discovered by Descartes and can be derived +from Th\={a}bit ibn Qurra's Rule with $k=7$ \cite{garciaetal1}.\ + +lemma Amicable_Example_Descartes: + shows "9363584 Amic 9437056" + +proof- + have a: "(7::nat)>1" by simp + have b: "prime (191::nat)" by (pratt (code)) + have c: "((3::nat)* (2^(7-1))-1) =191" by simp + have d: "prime((3::nat)* (2^(7-1))-1)" using b c by metis + have e: "prime (383::nat)" by (pratt (code)) + have f: "(3::nat)*(2^7)-1 = 383" by simp + have g: "prime ((3::nat)*(2^7)-1)" using e f by metis + have h: "prime (73727::nat)" by (pratt (code)) + have i: "(9::nat)*(2^(2*7-1))-1 = 73727" by simp + have j: "prime ((9::nat)*(2^(2*7-1))-1)" using i h by metis + have k: "((2^7)*(3*(2^(7-1))-1)*(3*(2^7)-1))Amic((2^7)*(9*(2^(2*7-1))-1))" + using Thabit_ibn_Qurra_Rule_Amicable a d g j by (metis mult.commute) + have l: "((2::nat)^7)* 191* 383 = 9363584" by simp + have m: "(((2::nat)^7)* 73727) = 9437056" by simp + + show ?thesis using a k l by simp +qed + + +text\In fact, the Amicable Pair (220, 284) is Regular and of type (2,1):\ + +lemma regularAmicPairExample: "regularAmicPair 220 284 \ typeAmic 220 284 = [2, 1]" +proof- + have a: "220 Amic 284" using Amicable_Example_Pythagoras by simp + have b: "gcd (220::nat) (284::nat) = 4" by eval + have c: "(220::nat) = 55*4" by simp + have d: "(284::nat) = 71*4" by simp + have e: "squarefree (55::nat)" using squarefree_def by eval + have f: "squarefree (71::nat)" using squarefree_def by eval + have g: "gcd (4::nat) (55::nat) =1" by eval + have h: "gcd (4::nat) (71::nat) =1" by eval + + have A: "regularAmicPair 220 284" + by (simp add: a b e g f h gcd.commute regularAmicPair_def) + have B: "(card {i.\ N. ( 220::nat) = N*(4::nat) \ prime i \ i dvd N \ \ i dvd 4}) = 2" + + proof- + obtain N::nat where N: "(220::nat) = N* 4" + by (metis c) + have NN:"N=55" using N by simp + have K1: "prime(5::nat)" by simp + have K2: "prime(11::nat)" by simp + have KK2: " \ prime (55::nat)" by simp + have KK3: " \ prime (1::nat)" by simp + have K: "set(divisors_nat 55 ) = {1, 5, 11, 55}" by eval + have KK: "{i. i dvd (55::nat)} = {1, 5, 11, 55}" + using K divisors_nat divisors_nat_def by auto + have K3 : "\ (5::nat) dvd 4" by simp + have K4 : "\ (11::nat) dvd 4" by simp + have K55: "(1::nat) \ {i. prime i \ i dvd 55}" using KK3 by simp + have K56: "(55::nat) \ {i. prime i \ i dvd 55}" using KK2 by simp + have K57: "(5::nat) \ {i. prime i \ i dvd 55}" using K1 by simp + have K58: "(11::nat) \ {i. prime i \ i dvd 55}" using K2 by simp + have K5: "{i.( prime i \ i dvd (55::nat) \ \ i dvd 4)} = {5, 11}" + + proof- + have K66: "{i.(prime i \ i dvd (55::nat) \ \ i dvd 4)}= +{i. prime i} \ {i. i dvd 55} \ { i. \ i dvd 4}" + by blast + show ?thesis using K66 K K1 K2 KK2 KK3 K3 K4 KK K55 K56 K57 K58 divisors_nat_def + divisors_nat by auto (*slow*) + qed + have K6: "card ({(5::nat), (11::nat)}) = 2" by simp + show ?thesis using K5 K6 by simp + qed + + have C: "(card {i. \N. (284::nat) = N*4 \ prime i \ i dvd N \ \ i dvd 4} ) = 1" + proof- + obtain N::nat where N: "284 = N*4" + by (metis d) + have NN: "N= 71" using N by simp + have K: "set(divisors_nat 71 ) = {1, 71 }" by eval + have KK: "{i. i dvd (71::nat)} = {1, 71}" + using K divisors_nat divisors_nat_def by auto + + have K55:"(1::nat) \ {i. prime i \ i dvd 71}" by simp + have K58: "(71::nat) \ {i. prime i \ i dvd 71}" by simp + have K5: "{i. prime i \ i dvd 71 \ \ i dvd 4} = {(71::nat)}" + proof- + have K66: "{i. prime i \ i dvd 71 \ \ i dvd 4}= +{i. prime i} \ {i. i dvd 71} \ { i. \ i dvd 4}" + by blast + show ?thesis using K KK K55 K58 + by (auto simp add: divisors_nat_def K66 divisors_nat) + qed + have K6: "card ({(71::nat)}) = 1" by simp + show ?thesis using K5 K6 by simp + qed + + show ?thesis using A B C + by (simp add: typeAmic_def b) +qed + +lemma abundant220ex: "abundant_number 220" +proof- + have "220 Amic 284" using Amicable_Example_Pythagoras by simp + moreover have "(220::nat) < 284" by simp + ultimately show ?thesis using Amicable_pair_abundant Amicable_pair_sym + by blast +qed + +lemma deficient284ex: "deficient_number 284" +proof- + have "220 Amic 284" using Amicable_Example_Pythagoras by simp + moreover have "(220::nat) < 284" by simp + ultimately show ?thesis using Amicable_pair_deficient Amicable_pair_sym + by blast +qed + + +section\Te Riele's Rule and Borho's Rule with breeders\ + +text\With the following rule \cite{garciaetal1} we can get an amicable pair from a known amicable +pair under certain conditions.\ + +theorem teRiele_Rule_Amicable: + fixes a u p r c q :: nat + assumes "a \ 1" and "u \ 1" + and "prime p" and "prime r" and "prime c" and "prime q" and "r \ c" + and "\(p dvd a)" and "(a*u) Amic (a*p)" and "gcd a (r*c)=1" + and "q = r+c+u" and "gcd (a*u) q =1" and "r*c = p*(r +c+ u) + p+u" + shows "(a*u*q) Amic (a*r*c)" + +proof- + have "p+1 >0" using assms by simp + have Z1: " r*c = p*q+p+u" using assms by auto + have Z2: "(r+1)*(c+1) = (q+1)*(p+1)" + proof- + have y: "(q+1)*(p+1) = q*p + q+ p+1 " by simp + have yy: "(r+1)*(c+1) = r*c + r+ c+1" by simp + show ?thesis using assms y Z1 yy by simp + qed + + have "Esigma(a) = (a*(u+p)/(p+1))" + proof- + have d: "Esigma (a*p) = (Esigma a)*(Esigma p)" + using assms gcd_Esigma_mult \prime p\ \\ (p dvd a)\ + by (metis gcd_unique_nat prime_nat_iff) + have dd : "Esigma (a*p) =(Esigma a)*(p+1)" + using d assms prime_sum_div by simp + have ddd: "Esigma (a*p) = a*(u+p)" using assms Amicable_pair_def + Amicable_pair_equiv_def + by (smt One_nat_def add_mult_distrib2 one_le_mult_iff prime_ge_1_nat) + + show ?thesis using d dd ddd Esigmanotzero assms(3) dvd_triv_right + nonzero_mult_div_cancel_right prime_nat_iff prime_sum_div real_of_nat_div + by (metis \0 < p + 1\ neq0_conv) + qed + + have "Esigma(r) = (r+1)" using assms prime_sum_div by blast + have "Esigma(c) = (c+1)" using assms prime_sum_div by blast + have "Esigma (a*r*c) = (Esigma a)*(Esigma r)*(Esigma c)" + proof- + have h: "Esigma (a*r*c) = (Esigma a)*(Esigma (r*c))" + using assms gcd_Esigma_mult + by (metis mult.assoc mult.commute) + have hh: " Esigma (r*c) = (Esigma r)*(Esigma c)" using assms prime_Esigma_mult + by (metis semiring_normalization_rules(7)) + + show ?thesis using h hh by auto + qed + + have A: "Esigma (a*u*q) = Esigma (a*r*c)" + proof- + have wk: "Esigma (a*u*q) = Esigma (a*u)*(q+1)" + using assms gcd_Esigma_mult by (simp add: prime_sum_div) + have wk1: "Esigma (a*u) = a*(u+p)" using assms Amicable_pair_equiv_def + by (smt One_nat_def add_mult_distrib2 one_le_mult_iff prime_ge_1_nat) + + have w3: "Esigma (a*u*q) = a*(u+p)*(q+1)" using wk wk1 by simp + have w4: "Esigma (a*r*c) =(Esigma a)*(r+1) * (c+1)" using assms + by (simp add: \Esigma (a*r*c) = Esigma a * Esigma r * Esigma c\ \Esigma c = c + 1\ + \Esigma r = r+1\) + + have we: "a*(u+p)*(q+1) = (Esigma a)*(r+1)*(c+1)" + proof- + have we1: "(Esigma a)*(r+1)*(c+1) = (a*(u+p)/(p+1))*(r+1)*(c+1)" + by (metis \real (Esigma a) = real (a*(u+p))/real(p+1)\ of_nat_mult) + have we12: " (Esigma a)*(r+1)*(c+1) = (a*(u+p)/(p+1))*(q+1)*(p+1)" using we1 Z2 + by (metis of_nat_mult semiring_normalization_rules(18)) + show ?thesis using we12 assms + by (smt nonzero_mult_div_cancel_right of_nat_1 of_nat_add of_nat_eq_iff of_nat_le_iff + of_nat_mult prime_ge_1_nat times_divide_eq_left) + qed + + show ?thesis using we w3 w4 by simp + qed + + have B : "Esigma (a*r*c) = (a*u*q)+(a*r*c)" + proof- + have a1: "(u+p)*(q+1) = (u*q+p*q+p+u)" using assms add_mult_distrib by auto + have a2: "(u+p)*(q+1)*(p+1) = (u*q+p*q+p+u)*(p+1)" using a1 assms by metis + have a3: "(u+p)*(r+1)*(c+1) = (u*q+p*q+p+u)*(p+1)" using assms a2 Z2 + by (metis semiring_normalization_rules(18)) + have a4: "a*(u+p)* (r+1)*(c+1) = a*(u*q+ p*q+p+u)*(p+1)" using assms a3 + by (metis semiring_normalization_rules(18)) + have a5: "a*(u+p)*(r+1)*(c+1) = a*(u*q+r*c)*(p+1)" using assms a4 Z1 + by (simp add: semiring_normalization_rules(21)) + have a6: "(a*(u+p)*(r+1)*(c+1))/(p+1) =(a*(u*q+ r*c)* (p+1))/(p+1)" using assms a5 + semiring_normalization_rules(21) \p+1 >0\ by auto + have a7: "(a*(u+p)*(r+1)*(c+1))/(p+1) =(a*(u*q+ r*c))" using assms a6 \p+1 >0\ + by (metis neq0_conv nonzero_mult_div_cancel_right of_nat_eq_0_iff of_nat_mult) + have a8:"(a*(u+p)/(p+1))*(r+1)*(c+1) = a*(u*q+r*c)" using assms a7 \p+1 >0\ + by (metis of_nat_mult times_divide_eq_left) + have a9: "(Esigma a)* Esigma(r)* Esigma(c) = a*(u*q+ r*c)" using a8 assms + \ Esigma(r) = (r+1)\ \ Esigma(c) = (c+1)\ + by (metis \real (Esigma a) = real (a*(u + p))/real(p + 1)\ of_nat_eq_iff of_nat_mult) + have a10: " Esigma(a*r*c) = a*(u*q+ r*c)" using a9 assms + \Esigma (a*r*c) = (Esigma a)*(Esigma r)*(Esigma c)\ by simp + + show ?thesis using a10 assms + by (simp add: add_mult_distrib2 mult.assoc) + qed + + show ?thesis using A B Amicable_pair_equiv_def_conv assms One_nat_def one_le_mult_iff + by (smt prime_ge_1_nat) + qed + + text \By replacing the assumption that \(a*u) Amic (a*p)\ in the above rule by te Riele with the + assumption that \(a*u) breeder u\, we obtain Borho's Rule with breeders \cite{garciaetal1}.\ + +theorem Borho_Rule_breeders_Amicable: + fixes a u r c q x :: nat + assumes "x \ 1" and "a \ 1" and "u \ 1" + and "prime r" and "prime c" and "prime q" and "r \ c" + and "Esigma (a*u) = a*u + a*x" "Esigma (a*u) = (Esigma a)*(x+1)" and "gcd a (r * c) =1" + and "gcd (a*u) q = 1" and "r * c = x+u + x*u +r*x +x*c" and "q = r+c+u" + shows "(a*u*q) Amic (a*r*c)" + +proof- + have a: "Esigma(a*u*q) = Esigma(a*u)*Esigma(q)" + using assms gcd_Esigma_mult by simp + have a1: "Esigma(a*r*c) = (Esigma a)*Esigma(r*c)" + using assms gcd_Esigma_mult by (metis mult.assoc mult.commute) + have a2: "Esigma(a*r*c) = (Esigma a)*(r+1)*(c+1)" + using a1 assms + by (metis mult.commute mult.left_commute prime_Esigma_mult prime_sum_div) + + have A: "Esigma (a*u*q) = Esigma(a*r*c)" + proof- + have d: "Esigma(a)*(r+1)*(c+1) = Esigma(a*u)*(q+1)" + proof- + have d1: "(r+1)*(c+1) =(x+1)*(q+1)" + proof- + have ce: "(r+1)*(c+1) = r*c+r+c+1" by simp + have ce1: "(r+1)*(c+1) = x+u+x*u+r*x+x*c+r+c+1" + using ce assms by simp + have de: "(x+1)*(q+1) = x*q +1+x+q" by simp + have de1: "(x+1)*(q+1) = x*(r+c+u)+1+x+ r+c+u" + using assms de by simp + show ?thesis using de1 ce1 add_mult_distrib2 by auto + qed + + show ?thesis using d1 assms + by (metis semiring_normalization_rules(18)) + qed + + show ?thesis using d a2 + by (simp add: a assms(6) prime_sum_div) + qed + + have B: "Esigma (a*u*q) = a*u*q + a*r*c" + proof- + have i: "Esigma (a*u*q) = Esigma(a*u)*(q+1)" + using a assms + by (simp add: prime_sum_div) + + have ii:"Esigma (a*u*q) = (a*u+ a*x)*(q+1)" + using assms i by auto + + have iii:"Esigma (a*u*q) = a*u*q +a*u+ a*x*q+ a*x" + using assms ii add_mult_distrib by simp + show ?thesis using iii assms + by (smt distrib_left semiring_normalization_rules) + qed + + show ?thesis using A B assms Amicable_pair_equiv_def_conv assms One_nat_def one_le_mult_iff + by (smt prime_ge_1_nat) +qed + +no_notation divisor (infixr "divisor" 80) + + +section\Acknowledgements\ + +text +\The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the +European Research Council and led by Professor Lawrence Paulson at the University of Cambridge, UK. +Many thanks to Lawrence Paulson for his help and suggestions. Number divisors were initially looked +up on \<^url>\https://onlinemathtools.com/find-all-divisors\.\ + +end diff --git a/thys/Amicable_Numbers/ROOT b/thys/Amicable_Numbers/ROOT new file mode 100644 --- /dev/null +++ b/thys/Amicable_Numbers/ROOT @@ -0,0 +1,13 @@ +chapter AFP + +session Amicable_Numbers (AFP) = "HOL-Number_Theory" + + options [timeout = 600] + sessions + "HOL-Computational_Algebra" + "Pratt_Certificate" + "Polynomial_Factorization" + theories + Amicable_Numbers + document_files + "root.tex" + "root.bib" diff --git a/thys/Amicable_Numbers/document/root.bib b/thys/Amicable_Numbers/document/root.bib new file mode 100644 --- /dev/null +++ b/thys/Amicable_Numbers/document/root.bib @@ -0,0 +1,56 @@ +@article{escott, + author = "Escott, E.B.", + title = "Amicable Numbers", + journal = "Scripta Mathematica", + volume = "12", + year = "1946", + pages = "61--72", + } + +@article{garciaetal1, + author = "Garc\'{i}a, M. and Pedersen, J.M. and te Riele, H.J.J.", + title = "Amicable Pairs, A Survey", + journal = "REPORT MAS-R0307", + year = "2003", + publisher = "Centrum Wiskunde \& Informatica" + } + + +@article{garciaetal2, + author = "Garc\'{i}a, M. and Pedersen, J.M. and te Riele, H.J.J.", + title = "Amicable Pairs, A Survey", + journal = "Fields Institute Communications", + volume = "41", + year = "2004", + pages = "1--19", + } + +@article{sandifer, + author = "Sandifer, E.", + title = "Amicable Pairs", + note = "How Euler Did It, The Euler Archive", + year = "2005", + howpublished = "MAA Online, \url{http://eulerarchive.maa.org/hedi/HEDI-2005-11.pdf}"} + + +@misc{aliquotwiki, + author = "Wikipedia", + title = "Aliquot Sum", + year = "2020", + howpublished = "\url{https://en.wikipedia.org/wiki/Aliquot_sum}"} + + +@misc{amicwiki, + author = "Wikipedia", + title = "Amicable Numbers", + year = "2020", + howpublished = "\url{https://en.wikipedia.org/wiki/Amicable_numbers}"} + +@misc{betrothedwiki, + author = "Wikipedia", + title = "Betrothed Numbers", + year = "2020", + howpublished = "\url{https://en.wikipedia.org/wiki/Betrothed_numbers}"} + + + diff --git a/thys/Amicable_Numbers/document/root.tex b/thys/Amicable_Numbers/document/root.tex new file mode 100644 --- /dev/null +++ b/thys/Amicable_Numbers/document/root.tex @@ -0,0 +1,37 @@ +\documentclass[11pt,a4paper]{article} +\usepackage{isabelle,isabellesym} + +% this should be the last package used +\usepackage{pdfsetup} + +% urls in roman style, theory text in math-similar italics +\urlstyle{rm} +\isabellestyle{it} + + +\begin{document} + +\title{Amicable Numbers} +\author{Angeliki Koutsoukou-Argyraki} +\maketitle + +\begin{abstract} +This is a formalisation of Amicable Numbers, involving some relevant material including +Euler's sigma function, some relevant definitions, results and examples as well as rules such as Th\={a}bit ibn Qurra's Rule, Euler's Rule, te Riele's Rule and Borho's Rule with breeders. +\\ \\ +The main sources are \cite{garciaetal1} \cite{garciaetal2}. Some auxiliary material can be found in \cite{escott} \cite{sandifer}. If not otherwise stated, the source of definitions is \cite{garciaetal1}. In a few definitions where we refer to Wikipedia articles \cite{aliquotwiki} \cite{amicwiki} \cite{betrothedwiki} this is explicitly mentioned. +\end{abstract} + +\newpage +\tableofcontents +\newpage + +% include generated text of all theories +\input{session} + +\newpage +\raggedright +\bibliographystyle{abbrv} +\bibliography{root} + +\end{document} diff --git a/thys/Berlekamp_Zassenhaus/Poly_Mod.thy b/thys/Berlekamp_Zassenhaus/Poly_Mod.thy --- a/thys/Berlekamp_Zassenhaus/Poly_Mod.thy +++ b/thys/Berlekamp_Zassenhaus/Poly_Mod.thy @@ -1,1053 +1,1076 @@ (* Authors: Jose Divasón Sebastiaan Joosten René Thiemann Akihisa Yamada *) section \Polynomials in Rings and Fields\ subsection \Polynomials in Rings\ text \We use a locale to work with polynomials in some integer-modulo ring.\ theory Poly_Mod imports "HOL-Computational_Algebra.Primes" Polynomial_Factorization.Square_Free_Factorization Unique_Factorization_Poly "HOL-Word.Misc_Arithmetic" begin locale poly_mod = fixes m :: "int" begin definition M :: "int \ int" where "M x = x mod m" lemma M_0[simp]: "M 0 = 0" by (auto simp add: M_def) lemma M_M[simp]: "M (M x) = M x" by (auto simp add: M_def) lemma M_plus[simp]: "M (M x + y) = M (x + y)" "M (x + M y) = M (x + y)" by (auto simp add: M_def mod_simps) lemma M_minus[simp]: "M (M x - y) = M (x - y)" "M (x - M y) = M (x - y)" by (auto simp add: M_def mod_simps) lemma M_times[simp]: "M (M x * y) = M (x * y)" "M (x * M y) = M (x * y)" by (auto simp add: M_def mod_simps) lemma M_sum: "M (sum (\ x. M (f x)) A) = M (sum f A)" proof (induct A rule: infinite_finite_induct) case (insert x A) from insert(1-2) have "M (\x\insert x A. M (f x)) = M (f x + M ((\x\A. M (f x))))" by simp also have "M ((\x\A. M (f x))) = M ((\x\A. f x))" using insert by simp finally show ?case using insert by simp qed auto +definition inv_M :: "int \ int" where + "inv_M = (\ x. if x + x \ m then x else x - m)" + +lemma M_inv_M_id[simp]: "M (inv_M x) = M x" + unfolding inv_M_def M_def by simp + definition Mp :: "int poly \ int poly" where "Mp = map_poly M" lemma Mp_0[simp]: "Mp 0 = 0" unfolding Mp_def by auto lemma Mp_coeff: "coeff (Mp f) i = M (coeff f i)" unfolding Mp_def by (simp add: M_def coeff_map_poly) abbreviation eq_m :: "int poly \ int poly \ bool" (infixl "=m" 50) where "f =m g \ (Mp f = Mp g)" notation eq_m (infixl "=m" 50) abbreviation degree_m :: "int poly \ nat" where "degree_m f \ degree (Mp f)" lemma mult_Mp[simp]: "Mp (Mp f * g) = Mp (f * g)" "Mp (f * Mp g) = Mp (f * g)" proof - { fix f g have "Mp (Mp f * g) = Mp (f * g)" unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff proof fix n show "M (\i\n. M (coeff f i) * coeff g (n - i)) = M (\i\n. coeff f i * coeff g (n - i))" by (subst M_sum[symmetric], rule sym, subst M_sum[symmetric], unfold M_times, simp) qed } from this[of f g] this[of g f] show "Mp (Mp f * g) = Mp (f * g)" "Mp (f * Mp g) = Mp (f * g)" by (auto simp: ac_simps) qed lemma plus_Mp[simp]: "Mp (Mp f + g) = Mp (f + g)" "Mp (f + Mp g) = Mp (f + g)" unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff by (auto simp add: Mp_coeff) lemma minus_Mp[simp]: "Mp (Mp f - g) = Mp (f - g)" "Mp (f - Mp g) = Mp (f - g)" unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff by (auto simp add: Mp_coeff) lemma Mp_smult[simp]: "Mp (smult (M a) f) = Mp (smult a f)" "Mp (smult a (Mp f)) = Mp (smult a f)" unfolding Mp_def smult_as_map_poly by (rule poly_eqI, auto simp: coeff_map_poly)+ lemma Mp_Mp[simp]: "Mp (Mp f) = Mp f" unfolding Mp_def by (intro poly_eqI, auto simp: coeff_map_poly) lemma Mp_smult_m_0[simp]: "Mp (smult m f) = 0" by (intro poly_eqI, auto simp: Mp_coeff, auto simp: M_def) definition dvdm :: "int poly \ int poly \ bool" (infix "dvdm" 50) where "f dvdm g = (\ h. g =m f * h)" notation dvdm (infix "dvdm" 50) lemma dvdmE: assumes fg: "f dvdm g" and main: "\h. g =m f * h \ Mp h = h \ thesis" shows "thesis" proof- from fg obtain h where "g =m f * h" by (auto simp: dvdm_def) then have "g =m f * Mp h" by auto from main[OF this] show thesis by auto qed lemma Mp_dvdm[simp]: "Mp f dvdm g \ f dvdm g" and dvdm_Mp[simp]: "f dvdm Mp g \ f dvdm g" by (auto simp: dvdm_def) definition irreducible_m where "irreducible_m f = (\f =m 0 \ \ f dvdm 1 \ (\a b. f =m a * b \ a dvdm 1 \ b dvdm 1))" definition irreducible\<^sub>d_m :: "int poly \ bool" where "irreducible\<^sub>d_m f \ degree_m f > 0 \ (\ g h. degree_m g < degree_m f \ degree_m h < degree_m f \ \ f =m g * h)" definition prime_elem_m where "prime_elem_m f \ \ f =m 0 \ \ f dvdm 1 \ (\g h. f dvdm g * h \ f dvdm g \ f dvdm h)" lemma degree_m_le_degree [intro!]: "degree_m f \ degree f" by (simp add: Mp_def degree_map_poly_le) lemma irreducible\<^sub>d_mI: assumes f0: "degree_m f > 0" and main: "\g h. Mp g = g \ Mp h = h \ degree g > 0 \ degree g < degree_m f \ degree h > 0 \ degree h < degree_m f \ f =m g * h \ False" shows "irreducible\<^sub>d_m f" proof (unfold irreducible\<^sub>d_m_def, intro conjI allI impI f0 notI) fix g h assume deg: "degree_m g < degree_m f" "degree_m h < degree_m f" and "f =m g * h" then have f: "f =m Mp g * Mp h" by simp have "degree_m f \ degree_m g + degree_m h" unfolding f using degree_mult_le order.trans by blast with main[of "Mp g" "Mp h"] deg f show False by auto qed lemma irreducible\<^sub>d_mE: assumes "irreducible\<^sub>d_m f" and "degree_m f > 0 \ (\g h. degree_m g < degree_m f \ degree_m h < degree_m f \ \ f =m g * h) \ thesis" shows thesis using assms by (unfold irreducible\<^sub>d_m_def, auto) lemma irreducible\<^sub>d_mD: assumes "irreducible\<^sub>d_m f" shows "degree_m f > 0" and "\g h. degree_m g < degree_m f \ degree_m h < degree_m f \ \ f =m g * h" using assms by (auto elim: irreducible\<^sub>d_mE) definition square_free_m :: "int poly \ bool" where "square_free_m f = (\ f =m 0 \ (\ g. degree_m g \ 0 \ \ (g * g dvdm f)))" definition coprime_m :: "int poly \ int poly \ bool" where "coprime_m f g = (\ h. h dvdm f \ h dvdm g \ h dvdm 1)" lemma Mp_square_free_m[simp]: "square_free_m (Mp f) = square_free_m f" unfolding square_free_m_def dvdm_def by simp lemma square_free_m_cong: "square_free_m f \ Mp f = Mp g \ square_free_m g" unfolding square_free_m_def dvdm_def by simp lemma Mp_prod_mset[simp]: "Mp (prod_mset (image_mset Mp b)) = Mp (prod_mset b)" proof (induct b) case (add x b) have "Mp (prod_mset (image_mset Mp ({#x#}+b))) = Mp (Mp x * prod_mset (image_mset Mp b))" by simp also have "\ = Mp (Mp x * Mp (prod_mset (image_mset Mp b)))" by simp also have "\ = Mp ( Mp x * Mp (prod_mset b))" unfolding add by simp finally show ?case by simp qed simp lemma Mp_prod_list: "Mp (prod_list (map Mp b)) = Mp (prod_list b)" proof (induct b) case (Cons b xs) have "Mp (prod_list (map Mp (b # xs))) = Mp (Mp b * prod_list (map Mp xs))" by simp also have "\ = Mp (Mp b * Mp (prod_list (map Mp xs)))" by simp also have "\ = Mp (Mp b * Mp (prod_list xs))" unfolding Cons by simp finally show ?case by simp qed simp text \Polynomial evaluation modulo\ definition "M_poly p x \ M (poly p x)" lemma M_poly_Mp[simp]: "M_poly (Mp p) = M_poly p" proof(intro ext, induct p) case 0 show ?case by auto next case IH: (pCons a p) from IH(1) have "M_poly (Mp (pCons a p)) x = M (a + M(x * M_poly (Mp p) x))" by (simp add: M_poly_def Mp_def) also note IH(2)[of x] finally show ?case by (simp add: M_poly_def) qed lemma Mp_lift_modulus: assumes "f =m g" shows "poly_mod.eq_m (m * k) (smult k f) (smult k g)" using assms unfolding poly_eq_iff poly_mod.Mp_coeff coeff_smult unfolding poly_mod.M_def by simp lemma Mp_ident_product: "n > 0 \ Mp f = f \ poly_mod.Mp (m * n) f = f" unfolding poly_eq_iff poly_mod.Mp_coeff poly_mod.M_def by (auto simp add: zmod_zmult2_eq) (metis mod_div_trivial mod_0) lemma Mp_shrink_modulus: assumes "poly_mod.eq_m (m * k) f g" "k \ 0" shows "f =m g" proof - from assms have a: "\ n. coeff f n mod (m * k) = coeff g n mod (m * k)" unfolding poly_eq_iff poly_mod.Mp_coeff unfolding poly_mod.M_def by auto show ?thesis unfolding poly_eq_iff poly_mod.Mp_coeff unfolding poly_mod.M_def proof fix n show "coeff f n mod m = coeff g n mod m" using a[of n] \k \ 0\ by (metis mod_mult_right_eq mult.commute mult_cancel_left mult_mod_right) qed qed lemma degree_m_le: "degree_m f \ degree f" unfolding Mp_def by (rule degree_map_poly_le) lemma degree_m_eq: "coeff f (degree f) mod m \ 0 \ m > 1 \ degree_m f = degree f" using degree_m_le[of f] unfolding Mp_def by (auto intro: degree_map_poly simp: Mp_def poly_mod.M_def) lemma degree_m_mult_le: assumes eq: "f =m g * h" shows "degree_m f \ degree_m g + degree_m h" proof - have "degree_m f = degree_m (Mp g * Mp h)" using eq by simp also have "\ \ degree (Mp g * Mp h)" by (rule degree_m_le) also have "\ \ degree_m g + degree_m h" by (rule degree_mult_le) finally show ?thesis by auto qed lemma degree_m_smult_le: "degree_m (smult c f) \ degree_m f" by (metis Mp_0 coeff_0 degree_le degree_m_le degree_smult_eq poly_mod.Mp_smult(2) smult_eq_0_iff) lemma irreducible_m_Mp[simp]: "irreducible_m (Mp f) \ irreducible_m f" by (simp add: irreducible_m_def) lemma eq_m_irreducible_m: "f =m g \ irreducible_m f \ irreducible_m g" using irreducible_m_Mp by metis definition mset_factors_m where "mset_factors_m F p \ F \ {#} \ (\f. f \# F \ irreducible_m f) \ p =m prod_mset F" end declare poly_mod.M_def[code] declare poly_mod.Mp_def[code] +declare poly_mod.inv_M_def[code] definition Irr_Mon :: "'a :: comm_semiring_1 poly set" where "Irr_Mon = {x. irreducible x \ monic x}" definition factorization :: "'a :: comm_semiring_1 poly set \ 'a poly \ ('a \ 'a poly multiset) \ bool" where "factorization Factors f cfs \ (case cfs of (c,fs) \ f = (smult c (prod_mset fs)) \ (set_mset fs \ Factors))" definition unique_factorization :: "'a :: comm_semiring_1 poly set \ 'a poly \ ('a \ 'a poly multiset) \ bool" where "unique_factorization Factors f cfs = (Collect (factorization Factors f) = {cfs})" lemma irreducible_multD: assumes l: "irreducible (a*b)" shows "a dvd 1 \ irreducible b \ b dvd 1 \ irreducible a" proof- from l have "a dvd 1 \ b dvd 1" by auto then show ?thesis proof(elim disjE) assume a: "a dvd 1" with l have "irreducible b" unfolding irreducible_def by (meson is_unit_mult_iff mult.left_commute mult_not_zero) with a show ?thesis by auto next assume a: "b dvd 1" with l have "irreducible a" unfolding irreducible_def by (meson is_unit_mult_iff mult_not_zero semiring_normalization_rules(16)) with a show ?thesis by auto qed qed lemma irreducible_dvd_prod_mset: fixes p :: "'a :: field poly" assumes irr: "irreducible p" and dvd: "p dvd prod_mset as" shows "\ a \# as. p dvd a" proof - from irr[unfolded irreducible_def] have deg: "degree p \ 0" by auto hence p1: "\ p dvd 1" unfolding dvd_def by (metis degree_1 nonzero_mult_div_cancel_left div_poly_less linorder_neqE_nat mult_not_zero not_less0 zero_neq_one) from dvd show ?thesis proof (induct as) case (add a as) hence "prod_mset (add_mset a as) = a * prod_mset as" by auto from add(2)[unfolded this] add(1) irr show ?case by auto qed (insert p1, auto) qed lemma monic_factorization_unique_mset: fixes P::"'a::field poly multiset" assumes eq: "prod_mset P = prod_mset Q" and P: "set_mset P \ {q. irreducible q \ monic q}" and Q: "set_mset Q \ {q. irreducible q \ monic q}" shows "P = Q" proof - { fix P Q :: "'a poly multiset" assume id: "prod_mset P = prod_mset Q" and P: "set_mset P \ {q. irreducible q \ monic q}" and Q: "set_mset Q \ {q. irreducible q \ monic q}" hence "P \# Q" proof (induct P arbitrary: Q) case (add x P Q') from add(3) have irr: "irreducible x" and mon: "monic x" by auto have "\ a \# Q'. x dvd a" proof (rule irreducible_dvd_prod_mset[OF irr]) show "x dvd prod_mset Q'" unfolding add(2)[symmetric] by simp qed then obtain y Q where Q': "Q' = add_mset y Q" and xy: "x dvd y" by (meson mset_add) from add(4) Q' have irr': "irreducible y" and mon': "monic y" by auto have "x = y" using irr irr' xy mon mon' by (metis irreducibleD' irreducible_not_unit poly_dvd_antisym) hence Q': "Q' = Q + {#x#}" using Q' by auto from mon have x0: "x \ 0" by auto from arg_cong[OF add(2)[unfolded Q'], of "\ z. z div x"] have eq: "prod_mset P = prod_mset Q" using x0 by auto from add(3-4)[unfolded Q'] have "set_mset P \ {q. irreducible q \ monic q}" "set_mset Q \ {q. irreducible q \ monic q}" by auto from add(1)[OF eq this] show ?case unfolding Q' by auto qed auto } from this[OF eq P Q] this[OF eq[symmetric] Q P] show ?thesis by auto qed lemma exactly_one_monic_factorization: assumes mon: "monic (f :: 'a :: field poly)" shows "\! fs. f = prod_mset fs \ set_mset fs \ {q. irreducible q \ monic q}" proof - from monic_irreducible_factorization[OF mon] obtain gs g where fin: "finite gs" and f: "f = (\a\gs. a ^ Suc (g a))" and gs: "gs \ {q. irreducible q \ monic q}" by blast from fin have "\ fs. set_mset fs \ gs \ prod_mset fs = (\a\gs. a ^ Suc (g a))" proof (induct gs) case (insert a gs) from insert(3) obtain fs where *: "set_mset fs \ gs" "prod_mset fs = (\a\gs. a ^ Suc (g a))" by auto let ?fs = "fs + replicate_mset (Suc (g a)) a" show ?case proof (rule exI[of _ "fs + replicate_mset (Suc (g a)) a"], intro conjI) show "set_mset ?fs \ insert a gs" using *(1) by auto show "prod_mset ?fs = (\a\insert a gs. a ^ Suc (g a))" by (subst prod.insert[OF insert(1-2)], auto simp: *(2)) qed qed simp then obtain fs where "set_mset fs \ gs" "prod_mset fs = (\a\gs. a ^ Suc (g a))" by auto with gs f have ex: "\fs. f = prod_mset fs \ set_mset fs \ {q. irreducible q \ monic q}" by (intro exI[of _ fs], auto) thus ?thesis using monic_factorization_unique_mset by blast qed lemma monic_prod_mset: fixes as :: "'a :: idom poly multiset" assumes "\ a. a \ set_mset as \ monic a" shows "monic (prod_mset as)" using assms by (induct as, auto intro: monic_mult) lemma exactly_one_factorization: assumes f: "f \ (0 :: 'a :: field poly)" shows "\! cfs. factorization Irr_Mon f cfs" proof - let ?a = "coeff f (degree f)" let ?b = "inverse ?a" let ?g = "smult ?b f" define g where "g = ?g" from f have a: "?a \ 0" "?b \ 0" by (auto simp: field_simps) hence "monic g" unfolding g_def by simp note ex1 = exactly_one_monic_factorization[OF this, folded Irr_Mon_def] then obtain fs where g: "g = prod_mset fs" "set_mset fs \ Irr_Mon" by auto let ?cfs = "(?a,fs)" have cfs: "factorization Irr_Mon f ?cfs" unfolding factorization_def split g(1)[symmetric] using g(2) unfolding g_def by (simp add: a field_simps) show ?thesis proof (rule, rule cfs) fix dgs assume fact: "factorization Irr_Mon f dgs" obtain d gs where dgs: "dgs = (d,gs)" by force from fact[unfolded factorization_def dgs split] have fd: "f = smult d (prod_mset gs)" and gs: "set_mset gs \ Irr_Mon" by auto have "monic (prod_mset gs)" by (rule monic_prod_mset, insert gs[unfolded Irr_Mon_def], auto) hence d: "d = ?a" unfolding fd by auto from arg_cong[OF fd, of "\ x. smult ?b x", unfolded d g_def[symmetric]] have "g = prod_mset gs" using a by (simp add: field_simps) with ex1 g gs have "gs = fs" by auto thus "dgs = ?cfs" unfolding dgs d by auto qed qed lemma mod_ident_iff: "m > 0 \ (x :: int) mod m = x \ x \ {0 ..< m}" by (metis Divides.pos_mod_bound Divides.pos_mod_sign atLeastLessThan_iff mod_pos_pos_trivial) declare prod_mset_prod_list[simp] lemma mult_1_is_id[simp]: "(*) (1 :: 'a :: ring_1) = id" by auto context poly_mod begin lemma degree_m_eq_monic: "monic f \ m > 1 \ degree_m f = degree f" by (rule degree_m_eq) auto lemma monic_degree_m_lift: assumes "monic f" "k > 1" "m > 1" shows "monic (poly_mod.Mp (m * k) f)" proof - have deg: "degree (poly_mod.Mp (m * k) f) = degree f" by (rule poly_mod.degree_m_eq_monic[of f "m * k"], insert assms, auto simp: less_1_mult) show ?thesis unfolding poly_mod.Mp_coeff deg assms poly_mod.M_def using assms(2-) by (simp add: less_1_mult) qed end locale poly_mod_2 = poly_mod m for m + assumes m1: "m > 1" begin lemma M_1[simp]: "M 1 = 1" unfolding M_def using m1 by auto lemma Mp_1[simp]: "Mp 1 = 1" unfolding Mp_def by simp lemma monic_degree_m[simp]: "monic f \ degree_m f = degree f" using degree_m_eq_monic[of f] using m1 by auto lemma monic_Mp: "monic f \ monic (Mp f)" by (auto simp: Mp_coeff) lemma Mp_0_smult_sdiv_poly: assumes "Mp f = 0" shows "smult m (sdiv_poly f m) = f" proof (intro poly_eqI, unfold Mp_coeff coeff_smult sdiv_poly_def, subst coeff_map_poly, force) fix n from assms have "coeff (Mp f) n = 0" by simp hence 0: "coeff f n mod m = 0" unfolding Mp_coeff M_def . thus "m * (coeff f n div m) = coeff f n" by auto qed lemma Mp_product_modulus: "m' = m * k \ k > 0 \ Mp (poly_mod.Mp m' f) = Mp f" by (intro poly_eqI, unfold poly_mod.Mp_coeff poly_mod.M_def, auto simp: mod_mod_cancel) +lemma inv_M_rev: assumes bnd: "2 * abs c < m" + shows "inv_M (M c) = c" +proof (cases "c \ 0") + case True + with bnd show ?thesis unfolding M_def inv_M_def by auto +next + case False + have 2: "\ v :: int. 2 * v = v + v" by auto + from False have c: "c < 0" by auto + from bnd c have "c + m > 0" "c + m < m" by auto + with c have cm: "c mod m = c + m" + by (metis le_less mod_add_self2 mod_pos_pos_trivial) + from c bnd have "2 * (c mod m) > m" unfolding cm by auto + with bnd c show ?thesis unfolding M_def inv_M_def cm by auto +qed + end lemma (in poly_mod) degree_m_eq_prime: assumes f0: "Mp f \ 0" and deg: "degree_m f = degree f" and eq: "f =m g * h" and p: "prime m" shows "degree_m f = degree_m g + degree_m h" proof - interpret poly_mod_2 m using prime_ge_2_int[OF p] unfolding poly_mod_2_def by simp from f0 eq have "Mp (Mp g * Mp h) \ 0" by auto hence "Mp g * Mp h \ 0" using Mp_0 by (cases "Mp g * Mp h", auto) hence g0: "Mp g \ 0" and h0: "Mp h \ 0" by auto have "degree (Mp (g * h)) = degree_m (Mp g * Mp h)" by simp also have "\ = degree (Mp g * Mp h)" proof (rule degree_m_eq[OF _ m1], rule) have id: "\ g. coeff (Mp g) (degree (Mp g)) mod m = coeff (Mp g) (degree (Mp g))" unfolding M_def[symmetric] Mp_coeff by simp from p have p': "prime m" unfolding prime_int_nat_transfer unfolding prime_nat_iff by auto assume "coeff (Mp g * Mp h) (degree (Mp g * Mp h)) mod m = 0" from this[unfolded coeff_degree_mult] have "coeff (Mp g) (degree (Mp g)) mod m = 0 \ coeff (Mp h) (degree (Mp h)) mod m = 0" unfolding dvd_eq_mod_eq_0[symmetric] using m1 prime_dvd_mult_int[OF p'] by auto with g0 h0 show False unfolding id by auto qed also have "\ = degree (Mp g) + degree (Mp h)" by (rule degree_mult_eq[OF g0 h0]) finally show ?thesis using eq by simp qed lemma monic_smult_add_small: assumes "f = 0 \ degree f < degree g" and mon: "monic g" shows "monic (g + smult q f)" proof (cases "f = 0") case True thus ?thesis using mon by auto next case False with assms have "degree f < degree g" by auto hence "degree (smult q f) < degree g" by (meson degree_smult_le not_less order_trans) thus ?thesis using mon using coeff_eq_0 degree_add_eq_left by fastforce qed context poly_mod begin definition factorization_m :: "int poly \ (int \ int poly multiset) \ bool" where "factorization_m f cfs \ (case cfs of (c,fs) \ f =m (smult c (prod_mset fs)) \ (\ f \ set_mset fs. irreducible\<^sub>d_m f \ monic (Mp f)))" definition Mf :: "int \ int poly multiset \ int \ int poly multiset" where "Mf cfs \ case cfs of (c,fs) \ (M c, image_mset Mp fs)" lemma Mf_Mf[simp]: "Mf (Mf x) = Mf x" proof (cases x, auto simp: Mf_def, goal_cases) case (1 c fs) show ?case by (induct fs, auto) qed definition equivalent_fact_m :: "int \ int poly multiset \ int \ int poly multiset \ bool" where "equivalent_fact_m cfs dgs = (Mf cfs = Mf dgs)" definition unique_factorization_m :: "int poly \ (int \ int poly multiset) \ bool" where "unique_factorization_m f cfs = (Mf ` Collect (factorization_m f) = {Mf cfs})" lemma Mp_irreducible\<^sub>d_m[simp]: "irreducible\<^sub>d_m (Mp f) = irreducible\<^sub>d_m f" unfolding irreducible\<^sub>d_m_def dvdm_def by simp lemma Mf_factorization_m[simp]: "factorization_m f (Mf cfs) = factorization_m f cfs" unfolding factorization_m_def Mf_def proof (cases cfs, simp, goal_cases) case (1 c fs) have "Mp (smult c (prod_mset fs)) = Mp (smult (M c) (Mp (prod_mset fs)))" by simp also have "\ = Mp (smult (M c) (Mp (prod_mset (image_mset Mp fs))))" unfolding Mp_prod_mset by simp also have "\ = Mp (smult (M c) (prod_mset (image_mset Mp fs)))" unfolding Mp_smult .. finally show ?case by auto qed lemma unique_factorization_m_imp_factorization: assumes "unique_factorization_m f cfs" shows "factorization_m f cfs" proof - from assms[unfolded unique_factorization_m_def] obtain dfs where fact: "factorization_m f dfs" and id: "Mf cfs = Mf dfs" by blast from fact have "factorization_m f (Mf dfs)" by simp from this[folded id] show ?thesis by simp qed lemma unique_factorization_m_alt_def: "unique_factorization_m f cfs = (factorization_m f cfs \ (\ dgs. factorization_m f dgs \ Mf dgs = Mf cfs))" using unique_factorization_m_imp_factorization[of f cfs] unfolding unique_factorization_m_def by auto end context poly_mod_2 begin lemma factorization_m_lead_coeff: assumes "factorization_m f (c,fs)" shows "lead_coeff (Mp f) = M c" proof - note * = assms[unfolded factorization_m_def split] have "monic (prod_mset (image_mset Mp fs))" by (rule monic_prod_mset, insert *, auto) hence "monic (Mp (prod_mset (image_mset Mp fs)))" by (rule monic_Mp) from this[unfolded Mp_prod_mset] have monic: "monic (Mp (prod_mset fs))" by simp from * have "lead_coeff (Mp f) = lead_coeff (Mp (smult c (prod_mset fs)))" by simp also have "Mp (smult c (prod_mset fs)) = Mp (smult (M c) (Mp (prod_mset fs)))" by simp finally show ?thesis using monic \smult c (prod_mset fs) =m smult (M c) (Mp (prod_mset fs))\ by (metis M_M M_def Mp_0 Mp_coeff lead_coeff_smult m1 mult_cancel_left2 poly_mod.degree_m_eq smult_eq_0_iff) qed lemma factorization_m_smult: assumes "factorization_m f (c,fs)" shows "factorization_m (smult d f) (c * d,fs)" proof - note * = assms[unfolded factorization_m_def split] from * have f: "Mp f = Mp (smult c (prod_mset fs))" by simp have "Mp (smult d f) = Mp (smult d (Mp f))" by simp also have "\ = Mp (smult (c * d) (prod_mset fs))" unfolding f by (simp add: ac_simps) finally show ?thesis using assms unfolding factorization_m_def split by auto qed lemma factorization_m_prod: assumes "factorization_m f (c,fs)" "factorization_m g (d,gs)" shows "factorization_m (f * g) (c * d, fs + gs)" proof - note * = assms[unfolded factorization_m_def split] have "Mp (f * g) = Mp (Mp f * Mp g)" by simp also have "Mp f = Mp (smult c (prod_mset fs))" using * by simp also have "Mp g = Mp (smult d (prod_mset gs))" using * by simp finally have "Mp (f * g) = Mp (smult (c * d) (prod_mset (fs + gs)))" unfolding mult_Mp by (simp add: ac_simps) with * show ?thesis unfolding factorization_m_def split by auto qed lemma Mp_factorization_m[simp]: "factorization_m (Mp f) cfs = factorization_m f cfs" unfolding factorization_m_def by simp lemma Mp_unique_factorization_m[simp]: "unique_factorization_m (Mp f) cfs = unique_factorization_m f cfs" unfolding unique_factorization_m_alt_def by simp lemma unique_factorization_m_cong: "unique_factorization_m f cfs \ Mp f = Mp g \ unique_factorization_m g cfs" unfolding Mp_unique_factorization_m[of f, symmetric] by simp lemma unique_factorization_mI: assumes "factorization_m f (c,fs)" and "\ d gs. factorization_m f (d,gs) \ Mf (d,gs) = Mf (c,fs)" shows "unique_factorization_m f (c,fs)" unfolding unique_factorization_m_alt_def by (intro conjI[OF assms(1)] allI impI, insert assms(2), auto) lemma unique_factorization_m_smult: assumes uf: "unique_factorization_m f (c,fs)" and d: "M (di * d) = 1" shows "unique_factorization_m (smult d f) (c * d,fs)" proof (rule unique_factorization_mI[OF factorization_m_smult]) show "factorization_m f (c, fs)" using uf[unfolded unique_factorization_m_alt_def] by auto fix e gs assume fact: "factorization_m (smult d f) (e,gs)" from factorization_m_smult[OF this, of di] have "factorization_m (Mp (smult di (smult d f))) (e * di, gs)" by simp also have "Mp (smult di (smult d f)) = Mp (smult (M (di * d)) f)" by simp also have "\ = Mp f" unfolding d by simp finally have fact: "factorization_m f (e * di, gs)" by simp with uf[unfolded unique_factorization_m_alt_def] have eq: "Mf (e * di, gs) = Mf (c, fs)" by blast from eq[unfolded Mf_def] have "M (e * di) = M c" by simp from arg_cong[OF this, of "\ x. M (x * d)"] have "M (e * M (di * d)) = M (c * d)" by (simp add: ac_simps) from this[unfolded d] have e: "M e = M (c * d)" by simp with eq show "Mf (e,gs) = Mf (c * d, fs)" unfolding Mf_def split by simp qed lemma unique_factorization_m_smultD: assumes uf: "unique_factorization_m (smult d f) (c,fs)" and d: "M (di * d) = 1" shows "unique_factorization_m f (c * di,fs)" proof - from d have d': "M (d * di) = 1" by (simp add: ac_simps) show ?thesis proof (rule unique_factorization_m_cong[OF unique_factorization_m_smult[OF uf d']], rule poly_eqI, unfold Mp_coeff coeff_smult) fix n have "M (di * (d * coeff f n)) = M (M (di * d) * coeff f n)" by (auto simp: ac_simps) from this[unfolded d] show "M (di * (d * coeff f n)) = M (coeff f n)" by simp qed qed lemma degree_m_eq_lead_coeff: "degree_m f = degree f \ lead_coeff (Mp f) = M (lead_coeff f)" by (simp add: Mp_coeff) lemma unique_factorization_m_zero: assumes "unique_factorization_m f (c,fs)" shows "M c \ 0" proof assume c: "M c = 0" from unique_factorization_m_imp_factorization[OF assms] have "Mp f = Mp (smult (M c) (prod_mset fs))" unfolding factorization_m_def split by simp from this[unfolded c] have f: "Mp f = 0" by simp have "factorization_m f (0,{#})" unfolding factorization_m_def split f by auto moreover have "Mf (0,{#}) = (0,{#})" unfolding Mf_def by auto ultimately have fact1: "(0, {#}) \ Mf ` Collect (factorization_m f)" by force define g :: "int poly" where "g = [:0,1:]" have mpg: "Mp g = [:0,1:]" unfolding Mp_def by (auto simp: g_def) { fix g h assume *: "degree (Mp g) = 0" "degree (Mp h) = 0" "[:0, 1:] = Mp (g * h)" from arg_cong[OF *(3), of degree] have "1 = degree_m (Mp g * Mp h)" by simp also have "\ \ degree (Mp g * Mp h)" by (rule degree_m_le) also have "\ \ degree (Mp g) + degree (Mp h)" by (rule degree_mult_le) also have "\ \ 0" using * by simp finally have False by simp } note irr = this have "factorization_m f (0,{# g #})" unfolding factorization_m_def split using irr by (auto simp: irreducible\<^sub>d_m_def f mpg) moreover have "Mf (0,{# g #}) = (0,{# g #})" unfolding Mf_def by (auto simp: mpg, simp add: g_def) ultimately have fact2: "(0, {#g#}) \ Mf ` Collect (factorization_m f)" by force note [simp] = assms[unfolded unique_factorization_m_def] from fact1[simplified, folded fact2[simplified]] show False by auto qed end context poly_mod begin lemma dvdm_smult: assumes "f dvdm g" shows "f dvdm smult c g" proof - from assms[unfolded dvdm_def] obtain h where g: "g =m f * h" by auto show ?thesis unfolding dvdm_def proof (intro exI[of _ "smult c h"]) have "Mp (smult c g) = Mp (smult c (Mp g))" by simp also have "Mp g = Mp (f * h)" using g by simp finally show "Mp (smult c g) = Mp (f * smult c h)" by simp qed qed lemma dvdm_factor: assumes "f dvdm g" shows "f dvdm g * h" proof - from assms[unfolded dvdm_def] obtain k where g: "g =m f * k" by auto show ?thesis unfolding dvdm_def proof (intro exI[of _ "h * k"]) have "Mp (g * h) = Mp (Mp g * h)" by simp also have "Mp g = Mp (f * k)" using g by simp finally show "Mp (g * h) = Mp (f * (h * k))" by (simp add: ac_simps) qed qed lemma square_free_m_smultD: assumes "square_free_m (smult c f)" shows "square_free_m f" unfolding square_free_m_def proof (intro conjI allI impI) fix g assume "degree_m g \ 0" with assms[unfolded square_free_m_def] have "\ g * g dvdm smult c f" by auto thus "\ g * g dvdm f" using dvdm_smult[of "g * g" f c] by blast next from assms[unfolded square_free_m_def] have "\ smult c f =m 0" by simp thus "\ f =m 0" by (metis Mp_smult(2) smult_0_right) qed lemma square_free_m_smultI: assumes sf: "square_free_m f" and inv: "M (ci * c) = 1" shows "square_free_m (smult c f)" proof - have "square_free_m (smult ci (smult c f))" proof (rule square_free_m_cong[OF sf], rule poly_eqI, unfold Mp_coeff coeff_smult) fix n have "M (ci * (c * coeff f n)) = M ( M (ci * c) * coeff f n)" by (simp add: ac_simps) from this[unfolded inv] show "M (coeff f n) = M (ci * (c * coeff f n))" by simp qed from square_free_m_smultD[OF this] show ?thesis . qed lemma square_free_m_factor: assumes "square_free_m (f * g)" shows "square_free_m f" "square_free_m g" proof - { fix f g assume sf: "square_free_m (f * g)" have "square_free_m f" unfolding square_free_m_def proof (intro conjI allI impI) fix h assume "degree_m h \ 0" with sf[unfolded square_free_m_def] have "\ h * h dvdm f * g" by auto thus "\ h * h dvdm f" using dvdm_factor[of "h * h" f g] by blast next from sf[unfolded square_free_m_def] have "\ f * g =m 0" by simp thus "\ f =m 0" by (metis mult.commute mult_zero_right poly_mod.mult_Mp(2)) qed } from this[of f g] this[of g f] assms show "square_free_m f" "square_free_m g" by (auto simp: ac_simps) qed end context poly_mod_2 begin lemma Mp_ident_iff: "Mp f = f \ (\ n. coeff f n \ {0 ..< m})" proof - have m0: "m > 0" using m1 by simp show ?thesis unfolding poly_eq_iff Mp_coeff M_def mod_ident_iff[OF m0] by simp qed lemma Mp_ident_iff': "Mp f = f \ (set (coeffs f) \ {0 ..< m})" proof - have 0: "0 \ {0 ..< m}" using m1 by auto have ran: "(\n. coeff f n \ {0.. range (coeff f) \ {0 ..< m}" by blast show ?thesis unfolding Mp_ident_iff ran using range_coeff[of f] 0 by auto qed end lemma Mp_Mp_pow_is_Mp: "n \ 0 \ p > 1 \ poly_mod.Mp p (poly_mod.Mp (p^n) f) = poly_mod.Mp p f" using poly_mod_2.Mp_product_modulus poly_mod_2_def by(subst power_eq_if, auto) lemma M_M_pow_is_M: "n \ 0 \ p > 1 \ poly_mod.M p (poly_mod.M (p^n) f) = poly_mod.M p f" using Mp_Mp_pow_is_Mp[of n p "[:f:]"] by (metis coeff_pCons_0 poly_mod.Mp_coeff) definition inverse_mod :: "int \ int \ int" where "inverse_mod x m = fst (bezout_coefficients x m)" lemma inverse_mod: "(inverse_mod x m * x) mod m = 1" if "coprime x m" "m > 1" proof - from bezout_coefficients [of x m "inverse_mod x m" "snd (bezout_coefficients x m)"] have "inverse_mod x m * x + snd (bezout_coefficients x m) * m = gcd x m" by (simp add: inverse_mod_def) with that have "inverse_mod x m * x + snd (bezout_coefficients x m) * m = 1" by simp then have "(inverse_mod x m * x + snd (bezout_coefficients x m) * m) mod m = 1 mod m" by simp with \m > 1\ show ?thesis by simp qed lemma inverse_mod_pow: "(inverse_mod x (p ^ n) * x) mod (p ^ n) = 1" if "coprime x p" "p > 1" "n \ 0" using that by (auto intro: inverse_mod) lemma (in poly_mod) inverse_mod_coprime: assumes p: "prime m" and cop: "coprime x m" shows "M (inverse_mod x m * x) = 1" unfolding M_def using inverse_mod_pow[OF cop, of 1] p by (auto simp: prime_int_iff) lemma (in poly_mod) inverse_mod_coprime_exp: assumes m: "m = p^n" and p: "prime p" and n: "n \ 0" and cop: "coprime x p" shows "M (inverse_mod x m * x) = 1" unfolding M_def unfolding m using inverse_mod_pow[OF cop _ n] p by (auto simp: prime_int_iff) locale poly_mod_prime = poly_mod p for p :: int + assumes prime: "prime p" begin sublocale poly_mod_2 p using prime unfolding poly_mod_2_def using prime_gt_1_int by force lemma square_free_m_prod_imp_coprime_m: assumes sf: "square_free_m (A * B)" shows "coprime_m A B" unfolding coprime_m_def proof (intro allI impI) fix h assume dvd: "h dvdm A" "h dvdm B" then obtain ha hb where *: "Mp A = Mp (h * ha)" "Mp B = Mp (h * hb)" unfolding dvdm_def by auto have AB: "Mp (A * B) = Mp (Mp A * Mp B)" by simp from this[unfolded *, simplified] have eq: "Mp (A * B) = Mp (h * h * (ha * hb))" by (simp add: ac_simps) hence dvd_hh: "(h * h) dvdm (A * B)" unfolding dvdm_def by auto { assume "degree_m h \ 0" from sf[unfolded square_free_m_def, THEN conjunct2, rule_format, OF this] have "\ h * h dvdm A * B" . with dvd_hh have False by simp } hence "degree (Mp h) = 0" by auto then obtain c where hc: "Mp h = [: c :]" by (rule degree_eq_zeroE) { assume "c = 0" hence "Mp h = 0" unfolding hc by auto with *(1) have "Mp A = 0" by (metis Mp_0 mult_zero_left poly_mod.mult_Mp(1)) with sf[unfolded square_free_m_def, THEN conjunct1] have False by (simp add: AB) } hence c0: "c \ 0" by auto with arg_cong[OF hc[symmetric], of "\ f. coeff f 0", unfolded Mp_coeff M_def] m1 have "c \ 0" "c < p" by auto with c0 have c_props:"c > 0" "c < p" by auto with prime have "prime p" by simp with c_props have "coprime p c" by (auto intro: prime_imp_coprime dest: zdvd_not_zless) then have "coprime c p" by (simp add: ac_simps) from inverse_mod_coprime[OF prime this] obtain d where d: "M (c * d) = 1" by (auto simp: ac_simps) show "h dvdm 1" unfolding dvdm_def proof (intro exI[of _ "[:d:]"]) have "Mp (h * [: d :]) = Mp (Mp h * [: d :])" by simp also have "\ = Mp ([: c * d :])" unfolding hc by (auto simp: ac_simps) also have "\ = [: M (c * d) :]" unfolding Mp_def by (metis (no_types) M_0 map_poly_pCons Mp_0 Mp_def d zero_neq_one) also have "\ = 1" unfolding d by simp finally show "Mp 1 = Mp (h * [:d:])" by simp qed qed lemma coprime_exp_mod: "coprime lu p \ n \ 0 \ lu mod p ^ n \ 0" using prime by fastforce end context poly_mod begin definition Dp :: "int poly \ int poly" where "Dp f = map_poly (\ a. a div m) f" lemma Dp_Mp_eq: "f = Mp f + smult m (Dp f)" by (rule poly_eqI, auto simp: Mp_coeff M_def Dp_def coeff_map_poly) lemma dvd_imp_dvdm: assumes "a dvd b" shows "a dvdm b" by (metis assms dvd_def dvdm_def) lemma dvdm_add: assumes a: "u dvdm a" and b: "u dvdm b" shows "u dvdm (a+b)" proof - obtain a' where a: "a =m u*a'" using a unfolding dvdm_def by auto obtain b' where b: "b =m u*b'" using b unfolding dvdm_def by auto have "Mp (a + b) = Mp (u*a'+u*b')" using a b by (metis poly_mod.plus_Mp(1) poly_mod.plus_Mp(2)) also have "... = Mp (u * (a'+ b'))" by (simp add: distrib_left) finally show ?thesis unfolding dvdm_def by auto qed lemma monic_dvdm_constant: assumes uk: "u dvdm [:k:]" and u1: "monic u" and u2: "degree u > 0" shows "k mod m = 0" proof - have d1: "degree_m [:k:] = degree [:k:]" by (metis degree_pCons_0 le_zero_eq poly_mod.degree_m_le) obtain h where h: "Mp [:k:] = Mp (u * h)" using uk unfolding dvdm_def by auto have d2: "degree_m [:k:] = degree_m (u*h)" using h by metis have d3: "degree (map_poly M (u * map_poly M h)) = degree (u * map_poly M h)" by (rule degree_map_poly) (metis coeff_degree_mult leading_coeff_0_iff mult.right_neutral M_M Mp_coeff Mp_def u1) thus ?thesis using assms d1 d2 d3 by (auto, metis M_def map_poly_pCons degree_mult_right_le h leD map_poly_0 mult_poly_0_right pCons_eq_0_iff M_0 Mp_def mult_Mp(2)) qed lemma div_mod_imp_dvdm: assumes "\q r. b = q * a + Polynomial.smult m r" shows "a dvdm b" proof - from assms obtain q r where b:"b = a * q + smult m r" by (metis mult.commute) have a: "Mp (Polynomial.smult m r) = 0" by auto show ?thesis proof (unfold dvdm_def, rule exI[of _ q]) have "Mp (a * q + smult m r) = Mp (a * q + Mp (smult m r))" using plus_Mp(2)[of "a*q" "smult m r"] by auto also have "... = Mp (a*q)" by auto finally show "eq_m b (a * q)" using b by auto qed qed lemma lead_coeff_monic_mult: fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly" assumes "monic p" shows "lead_coeff (p * q) = lead_coeff q" using assms by (simp add: lead_coeff_mult) lemma degree_m_mult_eq: assumes p: "monic p" and q: "lead_coeff q mod m \ 0" and m1: "m > 1" shows "degree (Mp (p * q)) = degree p + degree q" proof- have "lead_coeff (p * q) mod m \ 0" using q p by (auto simp: lead_coeff_monic_mult) with m1 show ?thesis by (auto simp: degree_m_eq intro!: degree_mult_eq) qed lemma dvdm_imp_degree_le: assumes pq: "p dvdm q" and p: "monic p" and q0: "Mp q \ 0" and m1: "m > 1" shows "degree p \ degree q" proof- from q0 have q: "lead_coeff (Mp q) mod m \ 0" by (metis Mp_Mp Mp_coeff leading_coeff_neq_0 M_def) from pq obtain r where Mpq: "Mp q = Mp (p * Mp r)" by (auto elim: dvdmE) with p q have "lead_coeff (Mp r) mod m \ 0" by (metis Mp_Mp Mp_coeff leading_coeff_0_iff mult_poly_0_right M_def) from degree_m_mult_eq[OF p this m1] Mpq have "degree p \ degree_m q" by simp thus ?thesis using degree_m_le le_trans by blast qed lemma dvdm_uminus [simp]: "p dvdm -q \ p dvdm q" by (metis add.inverse_inverse dvdm_smult smult_1_left smult_minus_left) (*TODO: simp?*) lemma Mp_const_poly: "Mp [:a:] = [:a mod m:]" by (simp add: Mp_def M_def Polynomial.map_poly_pCons) lemma dvdm_imp_div_mod: assumes "u dvdm g" shows "\q r. g = q*u + smult m r" proof - obtain q where q: "Mp g = Mp (u*q)" using assms unfolding dvdm_def by fast have "(u*q) = Mp (u*q) + smult m (Dp (u*q))" by (simp add: poly_mod.Dp_Mp_eq[of "u*q"]) hence uq: "Mp (u*q) = (u*q) - smult m (Dp (u*q))" by auto have g: "g = Mp g + smult m (Dp g)" by (simp add: poly_mod.Dp_Mp_eq[of "g"]) also have "... = poly_mod.Mp m (u*q) + smult m (Dp g)" using q by simp also have "... = u * q - smult m (Dp (u * q)) + smult m (Dp g)" unfolding uq by auto also have "... = u * q + smult m (-Dp (u*q)) + smult m (Dp g)" by auto also have "... = u * q + smult m (-Dp (u*q) + Dp g)" unfolding smult_add_right by auto also have "... = q * u + smult m (-Dp (u*q) + Dp g)" by auto finally show ?thesis by auto qed corollary div_mod_iff_dvdm: shows "a dvdm b = (\q r. b = q * a + Polynomial.smult m r)" using div_mod_imp_dvdm dvdm_imp_div_mod by blast lemma dvdmE': assumes "p dvdm q" and "\r. q =m p * Mp r \ thesis" shows thesis using assms by (auto simp: dvdm_def) end context poly_mod_2 begin lemma factorization_m_mem_dvdm: assumes fact: "factorization_m f (c,fs)" and mem: "Mp g \# image_mset Mp fs" shows "g dvdm f" proof - from fact have "factorization_m f (Mf (c, fs))" by auto then obtain l where f: "factorization_m f (l, image_mset Mp fs)" by (auto simp: Mf_def) from multi_member_split[OF mem] obtain ls where fs: "image_mset Mp fs = {# Mp g #} + ls" by auto from f[unfolded fs split factorization_m_def] show "g dvdm f" unfolding dvdm_def by (intro exI[of _ "smult l (prod_mset ls)"], auto simp del: Mp_smult simp add: Mp_smult(2)[of _ "Mp g * prod_mset ls", symmetric], simp) qed lemma dvdm_degree: "monic u \ u dvdm f \ Mp f \ 0 \ degree u \ degree f" using dvdm_imp_degree_le m1 by blast end lemma (in poly_mod_prime) pl_dvdm_imp_p_dvdm: assumes l0: "l \ 0" and pl_dvdm: "poly_mod.dvdm (p^l) a b" shows "a dvdm b" proof - from l0 have l_gt_0: "l > 0" by auto with m1 interpret pl: poly_mod_2 "p^l" by (unfold_locales, auto) have p_rw: "p * p ^ (l - 1) = p ^ l" by (rule power_minus_simp[symmetric, OF l_gt_0]) obtain q r where b: "b = q * a + smult (p^l) r" using pl.dvdm_imp_div_mod[OF pl_dvdm] by auto have "smult (p^l) r = smult p (smult (p ^ (l - 1)) r)" unfolding smult_smult p_rw .. hence b2: "b = q * a + smult p (smult (p ^ (l - 1)) r)" using b by auto show ?thesis by (rule div_mod_imp_dvdm, rule exI[of _ q], rule exI[of _ "(smult (p ^ (l - 1)) r)"], auto simp add: b2) qed end \ No newline at end of file diff --git a/thys/Berlekamp_Zassenhaus/Reconstruction.thy b/thys/Berlekamp_Zassenhaus/Reconstruction.thy --- a/thys/Berlekamp_Zassenhaus/Reconstruction.thy +++ b/thys/Berlekamp_Zassenhaus/Reconstruction.thy @@ -1,888 +1,865 @@ (* Authors: Jose Divasón Sebastiaan Joosten René Thiemann Akihisa Yamada *) subsection \Reconstruction of Integer Factorization\ text \We implemented Zassenhaus reconstruction-algorithm, i.e., given a factorization of $f$ mod $p^n$, the aim is to reconstruct a factorization of $f$ over the integers.\ theory Reconstruction imports Berlekamp_Hensel Polynomial_Factorization.Gauss_Lemma Polynomial_Factorization.Dvd_Int_Poly Polynomial_Factorization.Gcd_Rat_Poly Degree_Bound Factor_Bound Sublist_Iteration Poly_Mod begin hide_const coeff monom paragraph \Misc lemmas\ lemma foldr_of_Cons[simp]: "foldr Cons xs ys = xs @ ys" by (induct xs, auto) lemma foldr_map_prod[simp]: "foldr (\x. map_prod (f x) (g x)) xs base = (foldr f xs (fst base), foldr g xs (snd base))" by (induct xs, auto) paragraph \The main part\ context poly_mod begin -definition inv_M :: "int \ int" where - "inv_M = (\ x. if x + x \ m then x else x - m)" - definition inv_Mp :: "int poly \ int poly" where "inv_Mp = map_poly inv_M" definition mul_const :: "int poly \ int \ int" where "mul_const p c = (coeff p 0 * c) mod m" fun prod_list_m :: "int poly list \ int poly" where "prod_list_m (f # fs) = Mp (f * prod_list_m fs)" | "prod_list_m [] = 1" context fixes sl_impl :: "(int poly, int \ int poly list, 'state)subseqs_foldr_impl" and m2 :: "int" begin definition inv_M2 :: "int \ int" where "inv_M2 = (\ x. if x \ m2 then x else x - m)" definition inv_Mp2 :: "int poly \ int poly" where "inv_Mp2 = map_poly inv_M2" partial_function (tailrec) reconstruction :: "'state \ int poly \ int poly \ int \ nat \ nat \ int poly list \ int poly list \ (int \ (int poly list)) list \ int poly list" where "reconstruction state u luu lu d r vs res cands = (case cands of Nil \ let d' = Suc d in if d' + d' > r then (u # res) else (case next_subseqs_foldr sl_impl state of (cands,state') \ reconstruction state' u luu lu d' r vs res cands) | (lv',ws) # cands' \ let lv = inv_M2 lv' \ \\lv\ is last coefficient of \vb\ below\ in if lv dvd coeff luu 0 then let vb = inv_Mp2 (Mp (smult lu (prod_list_m ws))) in if vb dvd luu then let pp_vb = primitive_part vb; u' = u div pp_vb; r' = r - length ws; res' = pp_vb # res in if d + d > r' then u' # res' else let lu' = lead_coeff u'; vs' = fold remove1 ws vs; (cands'', state') = subseqs_foldr sl_impl (lu',[]) vs' d in reconstruction state' u' (smult lu' u') lu' d r' vs' res' cands'' else reconstruction state u luu lu d r vs res cands' else reconstruction state u luu lu d r vs res cands')" end end declare poly_mod.reconstruction.simps[code] declare poly_mod.prod_list_m.simps[code] declare poly_mod.mul_const_def[code] declare poly_mod.inv_M2_def[code] -declare poly_mod.inv_M_def[code] declare poly_mod.inv_Mp2_def[code_unfold] declare poly_mod.inv_Mp_def[code_unfold] definition zassenhaus_reconstruction_generic :: "(int poly, int \ int poly list, 'state) subseqs_foldr_impl \ int poly list \ int \ nat \ int poly \ int poly list" where "zassenhaus_reconstruction_generic sl_impl vs p n f = (let lf = lead_coeff f; pn = p^n; (_, state) = subseqs_foldr sl_impl (lf,[]) vs 0 in poly_mod.reconstruction pn sl_impl (pn div 2) state f (smult lf f) lf 0 (length vs) vs [] [])" lemma coeff_mult_0: "coeff (f * g) 0 = coeff f 0 * coeff g 0" by (metis poly_0_coeff_0 poly_mult) -lemma (in poly_mod) M_inv_M_id[simp]: "M (inv_M x) = M x" - unfolding inv_M_def M_def by simp - lemma lead_coeff_factor: assumes u: "u = v * (w :: 'a ::idom poly)" shows "smult (lead_coeff u) u = (smult (lead_coeff w) v) * (smult (lead_coeff v) w)" "lead_coeff (smult (lead_coeff w) v) = lead_coeff u" "lead_coeff (smult (lead_coeff v) w) = lead_coeff u" unfolding u by (auto simp: lead_coeff_mult lead_coeff_smult) lemma not_irreducible\<^sub>d_lead_coeff_factors: assumes "\ irreducible\<^sub>d (u :: 'a :: idom poly)" "degree u \ 0" shows "\ f g. smult (lead_coeff u) u = f * g \ lead_coeff f = lead_coeff u \ lead_coeff g = lead_coeff u \ degree f < degree u \ degree g < degree u" proof - from assms[unfolded irreducible\<^sub>d_def, simplified] obtain v w where deg: "degree v < degree u" "degree w < degree u" and u: "u = v * w" by auto define f where "f = smult (lead_coeff w) v" define g where "g = smult (lead_coeff v) w" note lf = lead_coeff_factor[OF u, folded f_def g_def] show ?thesis proof (intro exI conjI, (rule lf)+) show "degree f < degree u" "degree g < degree u" unfolding f_def g_def using deg u by auto qed qed lemma mset_subseqs_size: "mset ` {ys. ys \ set (subseqs xs) \ length ys = n} = {ws. ws \# mset xs \ size ws = n}" proof (induct xs arbitrary: n) case (Cons x xs n) show ?case (is "?l = ?r") proof (cases n) case 0 thus ?thesis by (auto simp: Let_def) next case (Suc m) have "?r = {ws. ws \# mset (x # xs)} \ {ps. size ps = n}" by auto also have "{ws. ws \# mset (x # xs)} = {ps. ps \# mset xs} \ ((\ ps. ps + {#x#}) ` {ps. ps \# mset xs})" by (simp add: multiset_subset_insert) also have "\ \ {ps. size ps = n} = {ps. ps \# mset xs \ size ps = n} \ ((\ ps. ps + {#x#}) ` {ps. ps \# mset xs \ size ps = m})" unfolding Suc by auto finally have id: "?r = {ps. ps \# mset xs \ size ps = n} \ (\ps. ps + {#x#}) ` {ps. ps \# mset xs \ size ps = m}" . have "?l = mset ` {ys \ set (subseqs xs). length ys = Suc m} \ mset ` {ys \ (#) x ` set (subseqs xs). length ys = Suc m}" unfolding Suc by (auto simp: Let_def) also have "mset ` {ys \ (#) x ` set (subseqs xs). length ys = Suc m} = (\ps. ps + {#x#}) ` mset ` {ys \ set (subseqs xs). length ys = m}" by force finally have id': "?l = mset ` {ys \ set (subseqs xs). length ys = Suc m} \ (\ps. ps + {#x#}) ` mset ` {ys \ set (subseqs xs). length ys = m}" . show ?thesis unfolding id id' Cons[symmetric] unfolding Suc by simp qed qed auto context poly_mod_2 begin lemma prod_list_m[simp]: "prod_list_m fs = Mp (prod_list fs)" by (induct fs, auto) lemma inv_Mp_coeff: "coeff (inv_Mp f) n = inv_M (coeff f n)" unfolding inv_Mp_def by (rule coeff_map_poly, insert m1, auto simp: inv_M_def) lemma Mp_inv_Mp_id[simp]: "Mp (inv_Mp f) = Mp f" unfolding poly_eq_iff Mp_coeff inv_Mp_coeff by simp -lemma inv_M_rev: assumes bnd: "2 * abs c < m" - shows "inv_M (M c) = c" -proof (cases "c \ 0") - case True - with bnd show ?thesis unfolding M_def inv_M_def by auto -next - case False - have 2: "\ v :: int. 2 * v = v + v" by auto - from False have c: "c < 0" by auto - from bnd c have "c + m > 0" "c + m < m" by auto - with c have cm: "c mod m = c + m" - by (metis le_less mod_add_self2 mod_pos_pos_trivial) - from c bnd have "2 * (c mod m) > m" unfolding cm by auto - with bnd c show ?thesis unfolding M_def inv_M_def cm by auto -qed - lemma inv_Mp_rev: assumes bnd: "\ n. 2 * abs (coeff f n) < m" shows "inv_Mp (Mp f) = f" proof (rule poly_eqI) fix n define c where "c = coeff f n" from bnd[of n, folded c_def] have bnd: "2 * abs c < m" by auto show "coeff (inv_Mp (Mp f)) n = coeff f n" unfolding inv_Mp_coeff Mp_coeff c_def[symmetric] using inv_M_rev[OF bnd] . qed lemma mul_const_commute_below: "mul_const x (mul_const y z) = mul_const y (mul_const x z)" unfolding mul_const_def by (metis mod_mult_right_eq mult.left_commute) context fixes p n and sl_impl :: "(int poly, int \ int poly list, 'state)subseqs_foldr_impl" and sli :: "int \ int poly list \ int poly list \ nat \ 'state \ bool" assumes prime: "prime p" and m: "m = p^n" and n: "n \ 0" and sl_impl: "correct_subseqs_foldr_impl (\x. map_prod (mul_const x) (Cons x)) sl_impl sli" begin private definition "test_dvd_exec lu u ws = (\ inv_Mp (Mp (smult lu (prod_mset ws))) dvd smult lu u)" private definition "test_dvd u ws = (\ v l. v dvd u \ 0 < degree v \ degree v < degree u \ \ v =m smult l (prod_mset ws))" private definition "large_m u vs = (\ v n. v dvd u \ degree v \ degree_bound vs \ 2 * abs (coeff v n) < m)" lemma large_m_factor: "large_m u vs \ v dvd u \ large_m v vs" unfolding large_m_def using dvd_trans by auto lemma test_dvd_factor: assumes u: "u \ 0" and test: "test_dvd u ws" and vu: "v dvd u" shows "test_dvd v ws" proof - from vu obtain w where uv: "u = v * w" unfolding dvd_def by auto from u have deg: "degree u = degree v + degree w" unfolding uv by (subst degree_mult_eq, auto) show ?thesis unfolding test_dvd_def proof (intro allI impI, goal_cases) case (1 f l) from 1(1) have fu: "f dvd u" unfolding uv by auto from 1(3) have deg: "degree f < degree u" unfolding deg by auto from test[unfolded test_dvd_def, rule_format, OF fu 1(2) deg] show ?case . qed qed lemma coprime_exp_mod: "coprime lu p \ prime p \ n \ 0 \ lu mod p ^ n \ 0" by (auto simp add: abs_of_pos prime_gt_0_int) interpretation correct_subseqs_foldr_impl "\x. map_prod (mul_const x) (Cons x)" sl_impl sli by fact lemma reconstruction: assumes res: "reconstruction sl_impl m2 state u (smult lu u) lu d r vs res cands = fs" and f: "f = u * prod_list res" and meas: "meas = (r - d, cands)" and dr: "d + d \ r" and r: "r = length vs" and cands: "set cands \ S (lu,[]) vs d" and d0: "d = 0 \ cands = []" and lu: "lu = lead_coeff u" and factors: "unique_factorization_m u (lu,mset vs)" and sf: "poly_mod.square_free_m p u" and cop: "coprime lu p" and norm: "\ v. v \ set vs \ Mp v = v" and tests: "\ ws. ws \# mset vs \ ws \ {#} \ size ws < d \ size ws = d \ ws \ (mset o snd) ` set cands \ test_dvd u ws" and irr: "\ f. f \ set res \ irreducible\<^sub>d f" and deg: "degree u > 0" and cands_ne: "cands \ [] \ d < r" and large: "\ v n. v dvd smult lu u \ degree v \ degree_bound vs \ 2 * abs (coeff v n) < m" and f0: "f \ 0" and state: "sli (lu,[]) vs d state" and m2: "m2 = m div 2" shows "f = prod_list fs \ (\ fi \ set fs. irreducible\<^sub>d fi)" proof - from large have large: "large_m (smult lu u) vs" unfolding large_m_def by auto interpret p: poly_mod_prime p using prime by unfold_locales define R where "R \ measures [ \ (n :: nat,cds :: (int \ int poly list) list). n, \ (n,cds). length cds]" have wf: "wf R" unfolding R_def by simp have mset_snd_S: "\ vs lu d. (mset \ snd) ` S (lu,[]) vs d = { ws. ws \# mset vs \ size ws = d}" by (fold mset_subseqs_size image_comp, unfold S_def image_Collect, auto) have inv_M2[simp]: "inv_M2 m2 = inv_M" unfolding inv_M2_def m2 inv_M_def by (intro ext, auto) have inv_Mp2[simp]: "inv_Mp2 m2 = inv_Mp" unfolding inv_Mp2_def inv_Mp_def by simp have p_Mp[simp]: "\ f. p.Mp (Mp f) = p.Mp f" using m p.m1 n Mp_Mp_pow_is_Mp by blast { fix u lu vs assume eq: "Mp u = Mp (smult lu (prod_mset vs))" and cop: "coprime lu p" and size: "size vs \ 0" and mi: "\ v. v \# vs \ irreducible\<^sub>d_m v \ monic v" from cop p.m1 have lu0: "lu \ 0" by auto from size have "vs \ {#}" by auto then obtain v vs' where vs_v: "vs = vs' + {#v#}" by (cases vs, auto) have mon: "monic (prod_mset vs)" by (rule monic_prod_mset, insert mi, auto) hence vs0: "prod_mset vs \ 0" by (metis coeff_0 zero_neq_one) from mon have l_vs: "lead_coeff (prod_mset vs) = 1" . have deg_ws: "degree_m (smult lu (prod_mset vs)) = degree (smult lu (prod_mset vs))" by (rule degree_m_eq[OF _ m1], unfold lead_coeff_smult, insert cop n p.m1 l_vs, auto simp: m) with eq have "degree_m u = degree (smult lu (prod_mset vs))" by auto also have "\ = degree (prod_mset vs' * v)" unfolding degree_smult_eq vs_v using lu0 by (simp add:ac_simps) also have "\ = degree (prod_mset vs') + degree v" by (rule degree_mult_eq, insert vs0[unfolded vs_v], auto) also have "\ \ degree v" by simp finally have deg_v: "degree v \ degree_m u" . from mi[unfolded vs_v, of v] have "irreducible\<^sub>d_m v" by auto hence "0 < degree_m v" unfolding irreducible\<^sub>d_m_def by auto also have "\ \ degree v" by (rule degree_m_le) also have "\ \ degree_m u" by (rule deg_v) also have "\ \ degree u" by (rule degree_m_le) finally have "degree u > 0" by auto } note deg_non_zero = this { fix u :: "int poly" and vs :: "int poly list" and d :: nat assume deg_u: "degree u > 0" and cop: "coprime (lead_coeff u) p" and uf: "unique_factorization_m u (lead_coeff u, mset vs)" and sf: "p.square_free_m u" and norm: "\ v. v \ set vs \ Mp v = v" and d: "size (mset vs) < d + d" and tests: "\ ws. ws \# mset vs \ ws \ {#} \ size ws < d \ test_dvd u ws" from deg_u have u0: "u \ 0" by auto have "irreducible\<^sub>d u" proof (rule irreducible\<^sub>dI[OF deg_u]) fix q q' :: "int poly" assume deg: "degree q > 0" "degree q < degree u" "degree q' > 0" "degree q' < degree u" and uq: "u = q * q'" then have qu: "q dvd u" and q'u: "q' dvd u" by auto from u0 have deg_u: "degree u = degree q + degree q'" unfolding uq by (subst degree_mult_eq, auto) from coprime_lead_coeff_factor[OF prime cop[unfolded uq]] have cop_q: "coprime (lead_coeff q) p" "coprime (lead_coeff q') p" by auto from unique_factorization_m_factor[OF prime uf[unfolded uq] _ _ n m, folded uq, OF cop sf] obtain fs gs l where uf_q: "unique_factorization_m q (lead_coeff q, fs)" and uf_q': "unique_factorization_m q' (lead_coeff q', gs)" and Mf_eq: "Mf (l, mset vs) = Mf (lead_coeff q * lead_coeff q', fs + gs)" and fs_id: "image_mset Mp fs = fs" and gs_id: "image_mset Mp gs = gs" by auto from Mf_eq fs_id gs_id have "image_mset Mp (mset vs) = fs + gs" unfolding Mf_def by auto also have "image_mset Mp (mset vs) = mset vs" using norm by (induct vs, auto) finally have eq: "mset vs = fs + gs" by simp from uf_q[unfolded unique_factorization_m_alt_def factorization_m_def split] have q_eq: "q =m smult (lead_coeff q) (prod_mset fs)" by auto have "degree_m q = degree q" by (rule degree_m_eq[OF _ m1], insert cop_q(1) n p.m1, unfold m, auto simp:) with q_eq have degm_q: "degree q = degree (Mp (smult (lead_coeff q) (prod_mset fs)))" by auto with deg have fs_nempty: "fs \ {#}" by (cases fs; cases "lead_coeff q = 0"; auto simp: Mp_def) from uf_q'[unfolded unique_factorization_m_alt_def factorization_m_def split] have q'_eq: "q' =m smult (lead_coeff q') (prod_mset gs)" by auto have "degree_m q' = degree q'" by (rule degree_m_eq[OF _ m1], insert cop_q(2) n p.m1, unfold m, auto simp:) with q'_eq have degm_q': "degree q' = degree (Mp (smult (lead_coeff q') (prod_mset gs)))" by auto with deg have gs_nempty: "gs \ {#}" by (cases gs; cases "lead_coeff q' = 0"; auto simp: Mp_def) from eq have size: "size fs + size gs = size (mset vs)" by auto with d have choice: "size fs < d \ size gs < d" by auto from choice show False proof assume fs: "size fs < d" from eq have sub: "fs \# mset vs" using mset_subset_eq_add_left[of fs gs] by auto have "test_dvd u fs" by (rule tests[OF sub fs_nempty, unfolded Nil], insert fs, auto) from this[unfolded test_dvd_def] uq deg q_eq show False by auto next assume gs: "size gs < d" from eq have sub: "gs \# mset vs" using mset_subset_eq_add_left[of fs gs] by auto have "test_dvd u gs" by (rule tests[OF sub gs_nempty, unfolded Nil], insert gs, auto) from this[unfolded test_dvd_def] uq deg q'_eq show False unfolding uq by auto qed qed } note irreducible\<^sub>d_via_tests = this show ?thesis using assms(1-16) large state proof (induct meas arbitrary: u lu d r vs res cands state rule: wf_induct[OF wf]) case (1 meas u lu d r vs res cands state) note IH = 1(1)[rule_format] note res = 1(2)[unfolded reconstruction.simps[where cands = cands]] note f = 1(3) note meas = 1(4) note dr = 1(5) note r = 1(6) note cands = 1(7) note d0 = 1(8) note lu = 1(9) note factors = 1(10) note sf = 1(11) note cop = 1(12) note norm = 1(13) note tests = 1(14) note irr = 1(15) note deg_u = 1(16) note cands_empty = 1(17) note large = 1(18) note state = 1(19) from unique_factorization_m_zero[OF factors] have Mlu0: "M lu \ 0" by auto from Mlu0 have lu0: "lu \ 0" by auto from this[unfolded lu] have u0: "u \ 0" by auto from unique_factorization_m_imp_factorization[OF factors] have fact: "factorization_m u (lu,mset vs)" by auto from this[unfolded factorization_m_def split] norm have vs: "u =m smult lu (prod_list vs)" and vs_mi: "\ f. f\#mset vs \ irreducible\<^sub>d_m f \ monic f" by auto let ?luu = "smult lu u" show ?case proof (cases cands) case Nil note res = res[unfolded this] let ?d' = "Suc d" show ?thesis proof (cases "r < ?d' + ?d'") case True with res have fs: "fs = u # res" by (simp add: Let_def) from True[unfolded r] have size: "size (mset vs) < ?d' + ?d'" by auto have "irreducible\<^sub>d u" by (rule irreducible\<^sub>d_via_tests[OF deg_u cop[unfolded lu] factors(1)[unfolded lu] sf norm size tests], auto simp: Nil) with fs f irr show ?thesis by simp next case False with dr have dr: "?d' + ?d' \ r" and dr': "?d' < r" by auto obtain state' cands' where sln: "next_subseqs_foldr sl_impl state = (cands',state')" by force from next_subseqs_foldr[OF sln state] have state': "sli (lu,[]) vs (Suc d) state'" and cands': "set cands' = S (lu,[]) vs (Suc d)" by auto let ?new = "subseqs_length mul_const lu ?d' vs" have R: "((r - Suc d, cands'), meas) \ R" unfolding meas R_def using False by auto from res False sln have fact: "reconstruction sl_impl m2 state' u ?luu lu ?d' r vs res cands' = fs" by auto show ?thesis proof (rule IH[OF R fact f refl dr r _ _ lu factors sf cop norm _ irr deg_u dr' large state'], goal_cases) case (4 ws) show ?case proof (cases "size ws = Suc d") case False with 4 have "size ws < Suc d" by auto thus ?thesis by (intro tests[OF 4(1-2)], unfold Nil, auto) next case True from 4(3)[unfolded cands' mset_snd_S] True 4(1) show ?thesis by auto qed qed (auto simp: cands') qed next case (Cons c cds) with d0 have d0: "d > 0" by auto obtain lv' ws where c: "c = (lv',ws)" by force let ?lv = "inv_M lv'" define vb where "vb \ inv_Mp (Mp (smult lu (prod_list ws)))" note res = res[unfolded Cons c list.simps split] from cands[unfolded Cons c S_def] have ws: "ws \ set (subseqs vs)" "length ws = d" and lv'': "lv' = foldr mul_const ws lu" by auto from subseqs_sub_mset[OF ws(1)] have ws_vs: "mset ws \# mset vs" "set ws \ set vs" using set_mset_mono subseqs_length_simple_False by auto fastforce have mon_ws: "monic (prod_mset (mset ws))" by (rule monic_prod_mset, insert ws_vs vs_mi, auto) have l_ws: "lead_coeff (prod_mset (mset ws)) = 1" using mon_ws . have lv': "M lv' = M (coeff (smult lu (prod_list ws)) 0)" unfolding lv'' coeff_smult by (induct ws arbitrary: lu, auto simp: mul_const_def M_def coeff_mult_0) (metis mod_mult_right_eq mult.left_commute) show ?thesis proof (cases "?lv dvd coeff ?luu 0 \ vb dvd ?luu") case False have ndvd: "\ vb dvd ?luu" proof assume dvd: "vb dvd ?luu" hence "coeff vb 0 dvd coeff ?luu 0" by (metis coeff_mult_0 dvd_def) with dvd False have "?lv \ coeff vb 0" by auto also have "lv' = M lv'" using ws(2) d0 unfolding lv'' by (cases ws, force, simp add: M_def mul_const_def) also have "inv_M (M lv') = coeff vb 0" unfolding vb_def inv_Mp_coeff Mp_coeff lv' by simp finally show False by simp qed from False res have res: "reconstruction sl_impl m2 state u ?luu lu d r vs res cds = fs" unfolding vb_def Let_def by auto have R: "((r - d, cds), meas) \ R" unfolding meas Cons R_def by auto from cands have cands: "set cds \ S (lu,[]) vs d" unfolding Cons by auto show ?thesis proof (rule IH[OF R res f refl dr r cands _ lu factors sf cop norm _ irr deg_u _ large state], goal_cases) case (3 ws') show ?case proof (cases "ws' = mset ws") case False show ?thesis by (rule tests[OF 3(1-2)], insert 3(3) False, force simp: Cons c) next case True have test: "test_dvd_exec lu u ws'" unfolding True test_dvd_exec_def using ndvd unfolding vb_def by simp show ?thesis unfolding test_dvd_def proof (intro allI impI notI, goal_cases) case (1 v l) note deg_v = 1(2-3) from 1(1) obtain w where u: "u = v * w" unfolding dvd_def by auto from u0 have deg: "degree u = degree v + degree w" unfolding u by (subst degree_mult_eq, auto) define v' where "v' = smult (lead_coeff w) v" define w' where "w' = smult (lead_coeff v) w" let ?ws = "smult (lead_coeff w * l) (prod_mset ws')" from arg_cong[OF 1(4), of "\ f. Mp (smult (lead_coeff w) f)"] have v'_ws': "Mp v' = Mp ?ws" unfolding v'_def by simp from lead_coeff_factor[OF u, folded v'_def w'_def] have prod: "?luu = v' * w'" and lc: "lead_coeff v' = lu" and "lead_coeff w' = lu" unfolding lu by auto with lu0 have lc0: "lead_coeff v \ 0" "lead_coeff w \ 0" unfolding v'_def w'_def by auto from deg_v have deg_w: "0 < degree w" "degree w < degree u" unfolding deg by auto from deg_v deg_w lc0 have deg: "0 < degree v'" "degree v' < degree u" "0 < degree w'" "degree w' < degree u" unfolding v'_def w'_def by auto from prod have v_dvd: "v' dvd ?luu" by auto with test[unfolded test_dvd_exec_def] have neq: "v' \ inv_Mp (Mp (smult lu (prod_mset ws')))" by auto have deg_m_v': "degree_m v' = degree v'" by (rule degree_m_eq[OF _ m1], unfold lc m, insert cop prime n coprime_exp_mod, auto) with v'_ws' have "degree v' = degree_m ?ws" by simp also have "\ \ degree_m (prod_mset ws')" by (rule degree_m_smult_le) also have "\ = degree_m (prod_list ws)" unfolding True by simp also have "\ \ degree (prod_list ws)" by (rule degree_m_le) also have "\ \ degree_bound vs" using ws_vs(1) ws(2) dr[unfolded r] degree_bound by auto finally have "degree v' \ degree_bound vs" . from inv_Mp_rev[OF large[unfolded large_m_def, rule_format, OF v_dvd this]] have inv: "inv_Mp (Mp v') = v'" by simp from arg_cong[OF v'_ws', of inv_Mp, unfolded inv] have v': "v' = inv_Mp (Mp ?ws)" by auto have deg_ws: "degree_m ?ws = degree ?ws" proof (rule degree_m_eq[OF _ m1], unfold lead_coeff_smult True l_ws, rule) assume "lead_coeff w * l * 1 mod m = 0" hence 0: "M (lead_coeff w * l) = 0" unfolding M_def by simp have "Mp ?ws = Mp (smult (M (lead_coeff w * l)) (prod_mset ws'))" by simp also have "\ = 0" unfolding 0 by simp finally have "Mp ?ws = 0" by simp hence "v' = 0" unfolding v' by (simp add: inv_Mp_def) with deg show False by auto qed from arg_cong[OF v', of "\ f. lead_coeff (Mp f)", simplified] have "M lu = M (lead_coeff v')" using lc by simp also have "\ = lead_coeff (Mp v')" by (rule degree_m_eq_lead_coeff[OF deg_m_v', symmetric]) also have "\ = lead_coeff (Mp ?ws)" using arg_cong[OF v', of "\ f. lead_coeff (Mp f)"] by simp also have "\ = M (lead_coeff ?ws)" by (rule degree_m_eq_lead_coeff[OF deg_ws]) also have "\ = M (lead_coeff w * l)" unfolding lead_coeff_smult True l_ws by simp finally have id: "M lu = M (lead_coeff w * l)" . note v' also have "Mp ?ws = Mp (smult (M (lead_coeff w * l)) (prod_mset ws'))" by simp also have "\ = Mp (smult lu (prod_mset ws'))" unfolding id[symmetric] by simp finally show False using neq by simp qed qed qed (insert d0 Cons cands_empty, auto) next case True define pp_vb where "pp_vb \ primitive_part vb" define u' where "u' \ u div pp_vb" define lu' where "lu' \ lead_coeff u'" let ?luu' = "smult lu' u'" define vs' where "vs' \ fold remove1 ws vs" obtain state' cands' where slc: "subseqs_foldr sl_impl (lu',[]) vs' d = (cands', state')" by force from subseqs_foldr[OF slc] have state': "sli (lu',[]) vs' d state'" and cands': "set cands' = S (lu',[]) vs' d" by auto let ?res' = "pp_vb # res" let ?r' = "r - length ws" note defs = vb_def pp_vb_def u'_def lu'_def vs'_def slc from fold_remove1_mset[OF subseqs_sub_mset[OF ws(1)]] have vs_split: "mset vs = mset vs' + mset ws" unfolding vs'_def by auto hence vs'_diff: "mset vs' = mset vs - mset ws" and ws_sub: "mset ws \# mset vs" by auto from arg_cong[OF vs_split, of size] have r': "?r' = length vs'" unfolding defs r by simp from arg_cong[OF vs_split, of prod_mset] have prod_vs: "prod_list vs = prod_list vs' * prod_list ws" by simp from arg_cong[OF vs_split, of set_mset] have set_vs: "set vs = set vs' \ set ws" by auto note inv = inverse_mod_coprime_exp[OF m prime n] note p_inv = p.inverse_mod_coprime[OF prime] from True res slc have res: "(if ?r' < d + d then u' # ?res' else reconstruction sl_impl m2 state' u' ?luu' lu' d ?r' vs' ?res' cands') = fs" unfolding Let_def defs by auto from True have dvd: "vb dvd ?luu" by simp from dvd_smult_int[OF lu0 this] have ppu: "pp_vb dvd u" unfolding defs by simp hence u: "u = pp_vb * u'" unfolding u'_def by (metis dvdE mult_eq_0_iff nonzero_mult_div_cancel_left) hence uu': "u' dvd u" unfolding dvd_def by auto have f: "f = u' * prod_list ?res'" using f u by auto let ?fact = "smult lu (prod_mset (mset ws))" have Mp_vb: "Mp vb = Mp (smult lu (prod_list ws))" unfolding vb_def by simp have pp_vb_vb: "smult (content vb) pp_vb = vb" unfolding pp_vb_def by (rule content_times_primitive_part) { have "smult (content vb) u = (smult (content vb) pp_vb) * u'" unfolding u by simp also have "smult (content vb) pp_vb = vb" by fact finally have "smult (content vb) u = vb * u'" by simp from arg_cong[OF this, of Mp] have "Mp (Mp vb * u') = Mp (smult (content vb) u)" by simp hence "Mp (smult (content vb) u) = Mp (?fact * u')" unfolding Mp_vb by simp } note prod = this from arg_cong[OF this, of p.Mp] have prod': "p.Mp (smult (content vb) u) = p.Mp (?fact * u')" by simp from dvd have "lead_coeff vb dvd lead_coeff (smult lu u)" by (metis dvd_def lead_coeff_mult) hence ldvd: "lead_coeff vb dvd lu * lu" unfolding lead_coeff_smult lu by simp from cop have cop_lu: "coprime (lu * lu) p" by simp from coprime_divisors [OF ldvd dvd_refl] cop_lu have cop_lvb: "coprime (lead_coeff vb) p" by simp then have cop_vb: "coprime (content vb) p" by (auto intro: coprime_divisors[OF content_dvd_coeff dvd_refl]) from u have "u' dvd u" unfolding dvd_def by auto hence "lead_coeff u' dvd lu" unfolding lu by (metis dvd_def lead_coeff_mult) from coprime_divisors[OF this dvd_refl] cop have "coprime (lead_coeff u') p" by simp hence "coprime (lu * lead_coeff u') p" and cop_lu': "coprime lu' p" using cop by (auto simp: lu'_def) hence cop': "coprime (lead_coeff (?fact * u')) p" unfolding lead_coeff_mult lead_coeff_smult l_ws by simp have "p.square_free_m (smult (content vb) u)" using cop_vb sf p_inv by (auto intro!: p.square_free_m_smultI) from p.square_free_m_cong[OF this prod'] have sf': "p.square_free_m (?fact * u')" by simp from p.square_free_m_factor[OF this] have sf_u': "p.square_free_m u'" by simp have "unique_factorization_m (smult (content vb) u) (lu * content vb, mset vs)" using cop_vb factors inv by (auto intro: unique_factorization_m_smult) from unique_factorization_m_cong[OF this prod] have uf: "unique_factorization_m (?fact * u') (lu * content vb, mset vs)" . { from unique_factorization_m_factor[OF prime uf cop' sf' n m] obtain fs gs where uf1: "unique_factorization_m ?fact (lu, fs)" and uf2: "unique_factorization_m u' (lu', gs)" and eq: "Mf (lu * content vb, mset vs) = Mf (lu * lead_coeff u', fs + gs)" unfolding lead_coeff_smult l_ws lu'_def by auto have "factorization_m ?fact (lu, mset ws)" unfolding factorization_m_def split using set_vs vs_mi norm by auto with uf1[unfolded unique_factorization_m_alt_def] have "Mf (lu,mset ws) = Mf (lu, fs)" by blast hence fs_ws: "image_mset Mp fs = image_mset Mp (mset ws)" unfolding Mf_def split by auto from eq[unfolded Mf_def split] have "image_mset Mp (mset vs) = image_mset Mp fs + image_mset Mp gs" by auto from this[unfolded fs_ws vs_split] have gs: "image_mset Mp gs = image_mset Mp (mset vs')" by (simp add: ac_simps) from uf1 have uf1: "unique_factorization_m ?fact (lu, mset ws)" unfolding unique_factorization_m_def Mf_def split fs_ws by simp from uf2 have uf2: "unique_factorization_m u' (lu', mset vs')" unfolding unique_factorization_m_def Mf_def split gs by simp note uf1 uf2 } hence factors: "unique_factorization_m u' (lu', mset vs')" "unique_factorization_m ?fact (lu, mset ws)" by auto have lu': "lu' = lead_coeff u'" unfolding lu'_def by simp have vb0: "vb \ 0" using dvd lu0 u0 by auto from ws(2) have size_ws: "size (mset ws) = d" by auto with d0 have size_ws0: "size (mset ws) \ 0" by auto then obtain w ws' where ws_w: "ws = w # ws'" by (cases ws, auto) from Mp_vb have Mp_vb': "Mp vb = Mp (smult lu (prod_mset (mset ws)))" by auto have deg_vb: "degree vb > 0" by (rule deg_non_zero[OF Mp_vb' cop size_ws0 vs_mi], insert vs_split, auto) also have "degree vb = degree pp_vb" using arg_cong[OF pp_vb_vb, of degree] unfolding degree_smult_eq using vb0 by auto finally have deg_pp: "degree pp_vb > 0" by auto hence pp_vb0: "pp_vb \ 0" by auto from factors(1)[unfolded unique_factorization_m_alt_def factorization_m_def] have eq_u': "Mp u' = Mp (smult lu' (prod_mset (mset vs')))" by auto from r'[unfolded ws(2)] dr have "length vs' + d = r" by auto from this cands_empty[unfolded Cons] have "size (mset vs') \ 0" by auto from deg_non_zero[OF eq_u' cop_lu' this vs_mi] have deg_u': "degree u' > 0" unfolding vs_split by auto have irr_pp: "irreducible\<^sub>d pp_vb" proof (rule irreducible\<^sub>dI[OF deg_pp]) fix q r :: "int poly" assume deg_q: "degree q > 0" "degree q < degree pp_vb" and deg_r: "degree r > 0" "degree r < degree pp_vb" and pp_qr: "pp_vb = q * r" then have qvb: "q dvd pp_vb" by auto from dvd_trans[OF qvb ppu] have qu: "q dvd u" . have "degree pp_vb = degree q + degree r" unfolding pp_qr by (subst degree_mult_eq, insert pp_qr pp_vb0, auto) have uf: "unique_factorization_m (smult (content vb) pp_vb) (lu, mset ws)" unfolding pp_vb_vb by (rule unique_factorization_m_cong[OF factors(2)], insert Mp_vb, auto) from unique_factorization_m_smultD[OF uf inv] cop_vb have uf: "unique_factorization_m pp_vb (lu * inverse_mod (content vb) m, mset ws)" by auto from ppu have "lead_coeff pp_vb dvd lu" unfolding lu by (metis dvd_def lead_coeff_mult) from coprime_divisors[OF this dvd_refl] cop have cop_pp: "coprime (lead_coeff pp_vb) p" by simp from coprime_lead_coeff_factor[OF prime cop_pp[unfolded pp_qr]] have cop_qr: "coprime (lead_coeff q) p" "coprime (lead_coeff r) p" by auto from p.square_free_m_factor[OF sf[unfolded u]] have sf_pp: "p.square_free_m pp_vb" by simp from unique_factorization_m_factor[OF prime uf[unfolded pp_qr] _ _ n m, folded pp_qr, OF cop_pp sf_pp] obtain fs gs l where uf_q: "unique_factorization_m q (lead_coeff q, fs)" and uf_r: "unique_factorization_m r (lead_coeff r, gs)" and Mf_eq: "Mf (l, mset ws) = Mf (lead_coeff q * lead_coeff r, fs + gs)" and fs_id: "image_mset Mp fs = fs" and gs_id: "image_mset Mp gs = gs" by auto from Mf_eq have "image_mset Mp (mset ws) = image_mset Mp fs + image_mset Mp gs" unfolding Mf_def by auto also have "image_mset Mp (mset ws) = mset ws" using norm ws_vs(2) by (induct ws, auto) finally have eq: "mset ws = image_mset Mp fs + image_mset Mp gs" by simp from arg_cong[OF this, of size, unfolded size_ws] have size: "size fs + size gs = d" by auto from uf_q[unfolded unique_factorization_m_alt_def factorization_m_def split] have q_eq: "q =m smult (lead_coeff q) (prod_mset fs)" by auto have "degree_m q = degree q" by (rule degree_m_eq[OF _ m1], insert cop_qr(1) n p.m1, unfold m, auto simp:) with q_eq have degm_q: "degree q = degree (Mp (smult (lead_coeff q) (prod_mset fs)))" by auto with deg_q have fs_nempty: "fs \ {#}" by (cases fs; cases "lead_coeff q = 0"; auto simp: Mp_def) from uf_r[unfolded unique_factorization_m_alt_def factorization_m_def split] have r_eq: "r =m smult (lead_coeff r) (prod_mset gs)" by auto have "degree_m r = degree r" by (rule degree_m_eq[OF _ m1], insert cop_qr(2) n p.m1, unfold m, auto simp:) with r_eq have degm_r: "degree r = degree (Mp (smult (lead_coeff r) (prod_mset gs)))" by auto with deg_r have gs_nempty: "gs \ {#}" by (cases gs; cases "lead_coeff r = 0"; auto simp: Mp_def) from gs_nempty have "size gs \ 0" by auto with size have size_fs: "size fs < d" by linarith note * = tests[unfolded test_dvd_def, rule_format, OF _ fs_nempty _ qu, of "lead_coeff q"] from ppu have "degree pp_vb \ degree u" using dvd_imp_degree_le u0 by blast with deg_q q_eq size_fs have "\ fs \# mset vs" by (auto dest!:*) thus False unfolding vs_split eq fs_id gs_id using mset_subset_eq_add_left[of fs "mset vs' + gs"] by (auto simp: ac_simps) qed { fix ws' assume *: "ws' \# mset vs'" "ws' \ {#}" "size ws' < d \ size ws' = d \ ws' \ (mset \ snd) ` set cands'" from *(1) have "ws' \# mset vs" unfolding vs_split by (simp add: subset_mset.add_increasing2) from tests[OF this *(2)] *(3)[unfolded cands' mset_snd_S] *(1) have "test_dvd u ws'" by auto from test_dvd_factor[OF u0 this[unfolded lu] uu'] have "test_dvd u' ws'" . } note tests' = this show ?thesis proof (cases "?r' < d + d") case True with res have res: "fs = u' # ?res'" by auto from True r' have size: "size (mset vs') < d + d" by auto have "irreducible\<^sub>d u'" by (rule irreducible\<^sub>d_via_tests[OF deg_u' cop_lu'[unfolded lu'] factors(1)[unfolded lu'] sf_u' norm size tests'], insert set_vs, auto) with f res irr irr_pp show ?thesis by auto next case False have res: "reconstruction sl_impl m2 state' u' ?luu' lu' d ?r' vs' ?res' cands' = fs" using False res by auto from False have dr: "d + d \ ?r'" by auto from False dr r r' d0 ws Cons have le: "?r' - d < r - d" by (cases ws, auto) hence R: "((?r' - d, cands'), meas) \ R" unfolding meas R_def by simp have dr': "d < ?r'" using le False ws(2) by linarith have luu': "lu' dvd lu" using \lead_coeff u' dvd lu\ unfolding lu' . have "large_m (smult lu' u') vs" by (rule large_m_factor[OF large dvd_dvd_smult], insert uu' luu') moreover have "degree_bound vs' \ degree_bound vs" unfolding vs'_def degree_bound_def by (rule max_factor_degree_mono) ultimately have large': "large_m (smult lu' u') vs'" unfolding large_m_def by auto show ?thesis by (rule IH[OF R res f refl dr r' _ _ lu' factors(1) sf_u' cop_lu' norm tests' _ deg_u' dr' large' state'], insert irr irr_pp d0 Cons set_vs, auto simp: cands') qed qed qed qed qed end end (* select implementation of subseqs *) definition zassenhaus_reconstruction :: "int poly list \ int \ nat \ int poly \ int poly list" where "zassenhaus_reconstruction vs p n f = (let mul = poly_mod.mul_const (p^n); sl_impl = my_subseqs.impl (\x. map_prod (mul x) (Cons x)) in zassenhaus_reconstruction_generic sl_impl vs p n f)" context fixes p n f hs assumes prime: "prime p" and cop: "coprime (lead_coeff f) p" and sf: "poly_mod.square_free_m p f" and deg: "degree f > 0" and bh: "berlekamp_hensel p n f = hs" and bnd: "2 * \lead_coeff f\ * factor_bound f (degree_bound hs) < p ^ n" begin private lemma n: "n \ 0" proof assume n: "n = 0" hence pn: "p^n = 1" by auto let ?f = "smult (lead_coeff f) f" let ?d = "degree_bound hs" have f: "f \ 0" using deg by auto hence "lead_coeff f \ 0" by auto hence lf: "abs (lead_coeff f) > 0" by auto obtain c d where c: "factor_bound f (degree_bound hs) = c" "abs (lead_coeff f) = d" by auto { assume *: "1 \ c" "2 * d * c < 1" "0 < d" hence "1 \ d" by auto from mult_mono[OF this *(1)] * have "1 \ d * c" by auto hence "2 * d * c \ 2" by auto with * have False by auto } note tedious = this have "1 \ factor_bound f ?d" using factor_bound[OF f, of 1 ?d 0] by auto also have "\ = 0" using bnd unfolding pn using factor_bound_ge_0[of f "degree_bound hs", OF f] lf unfolding c by (cases "c \ 1"; insert tedious, auto) finally show False by simp qed interpretation p: poly_mod_prime p using prime by unfold_locales lemma zassenhaus_reconstruction_generic: assumes sl_impl: "correct_subseqs_foldr_impl (\v. map_prod (poly_mod.mul_const (p^n) v) (Cons v)) sl_impl sli" and res: "zassenhaus_reconstruction_generic sl_impl hs p n f = fs" shows "f = prod_list fs \ (\ fi \ set fs. irreducible\<^sub>d fi)" proof - let ?lc = "lead_coeff f" let ?ff = "smult ?lc f" let ?q = "p^n" have p1: "p > 1" using prime unfolding prime_int_iff by simp interpret poly_mod_2 "p^n" using p1 n unfolding poly_mod_2_def by simp obtain cands state where slc: "subseqs_foldr sl_impl (lead_coeff f, []) hs 0 = (cands, state)" by force interpret correct_subseqs_foldr_impl "\x. map_prod (mul_const x) (Cons x)" sl_impl sli by fact from subseqs_foldr[OF slc] have state: "sli (lead_coeff f, []) hs 0 state" by auto from res[unfolded zassenhaus_reconstruction_generic_def bh split Let_def slc fst_conv] have res: "reconstruction sl_impl (?q div 2) state f ?ff ?lc 0 (length hs) hs [] [] = fs" by auto from p.berlekamp_hensel_unique[OF cop sf bh n] have ufact: "unique_factorization_m f (?lc, mset hs)" by simp note bh = p.berlekamp_hensel[OF cop sf bh n] from deg have f0: "f \ 0" and lf0: "?lc \ 0" by auto hence ff0: "?ff \ 0" by auto have bnd: "\g k. g dvd ?ff \ degree g \ degree_bound hs \ 2 * \coeff g k\ < p ^ n" proof (intro allI impI, goal_cases) case (1 g k) from factor_bound_smult[OF f0 lf0 1, of k] have "\coeff g k\ \ \?lc\ * factor_bound f (degree_bound hs)" . hence "2 * \coeff g k\ \ 2 * \?lc\ * factor_bound f (degree_bound hs)" by auto also have "\ < p^n" using bnd . finally show ?case . qed note bh' = bh[unfolded factorization_m_def split] have deg_f: "degree_m f = degree f" using cop unique_factorization_m_zero [OF ufact] n by (auto simp add: M_def intro: degree_m_eq [OF _ m1]) have mon_hs: "monic (prod_list hs)" using bh' by (auto intro: monic_prod_list) have Mlc: "M ?lc \ {1 ..< p^n}" by (rule prime_cop_exp_poly_mod[OF prime cop n]) hence "?lc \ 0" by auto hence f0: "f \ 0" by auto have degm: "degree_m (smult ?lc (prod_list hs)) = degree (smult ?lc (prod_list hs))" by (rule degree_m_eq[OF _ m1], insert n bh mon_hs Mlc, auto simp: M_def) from reconstruction[OF prime refl n sl_impl res _ refl _ refl _ refl refl ufact sf cop _ _ _ deg _ bnd f0] bh(2) state show ?thesis by simp qed lemma zassenhaus_reconstruction_irreducible\<^sub>d: assumes res: "zassenhaus_reconstruction hs p n f = fs" shows "f = prod_list fs \ (\ fi \ set fs. irreducible\<^sub>d fi)" by (rule zassenhaus_reconstruction_generic[OF my_subseqs.impl_correct res[unfolded zassenhaus_reconstruction_def Let_def]]) corollary zassenhaus_reconstruction: assumes pr: "primitive f" assumes res: "zassenhaus_reconstruction hs p n f = fs" shows "f = prod_list fs \ (\ fi \ set fs. irreducible fi)" using zassenhaus_reconstruction_irreducible\<^sub>d[OF res] pr irreducible_primitive_connect[OF primitive_prod_list] by auto end end diff --git a/thys/Chandy_Lamport/Co_Snapshot.thy b/thys/Chandy_Lamport/Co_Snapshot.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Co_Snapshot.thy @@ -0,0 +1,334 @@ +theory Co_Snapshot + imports + Snapshot + Ordered_Resolution_Prover.Lazy_List_Chain +begin + +section \Extension to infinite traces\ + +text \The computation locale assumes that there already exists a known +final configuration $c'$ to the given initial $c$ and trace $t$. However, +we can show that the snapshot algorithm must terminate correctly even if +the underlying computation itself does not terminate. We relax +the trace relation to allow for a potentially infinite number of ``intermediate'' events, and +show that the algorithm's correctness still holds when imposing the same constraints +as in the computation locale. + +We use a preexisting theory of lazy list chains by Schlichtkrull, Blanchette, +Traytel and Waldmann~\cite{Ordered_Resolution_Prover-AFP} to construct infinite traces.\ + +primrec ltake where + "ltake 0 t = []" +| "ltake (Suc i) t = (case t of LNil \ [] | LCons x t' \ x # ltake i t')" + +primrec ldrop where + "ldrop 0 t = t" +| "ldrop (Suc i) t = (case t of LNil \ LNil | LCons x t' \ ldrop i t')" + +lemma ltake_LNil[simp]: "ltake i LNil = []" + by (induct i) auto + +lemma ltake_LCons: "0 < i \ ltake i (LCons x t) = x # ltake (i - 1) t" + by (induct i) auto + +lemma take_ltake: "i \ j \ take i (ltake j xs) = ltake i xs" + by (induct j arbitrary: i xs) (auto simp: le_Suc_eq take_Cons' ltake_LCons split: llist.splits if_splits) + +lemma nth_ltake [simp]: "i < min n (llength xs) \ (ltake n xs) ! i = lnth xs i" + by (induct n arbitrary: i xs) + (auto simp: nth_Cons' gr0_conv_Suc eSuc_enat[symmetric] split: llist.splits) + +lemma length_ltake[simp]: "length (ltake i xs) = (case llength xs of \ \ i | enat m \ min i m)" + by (induct i arbitrary: xs) + (auto simp: zero_enat_def[symmetric] eSuc_enat split: llist.splits enat.splits) + +lemma ltake_prepend: + "ltake i (prepend xs t) = (if i \ length xs then take i xs else xs @ ltake (i - length xs) t)" +proof (induct i arbitrary: xs t) + case 0 + then show ?case + by (cases xs) auto +next + case (Suc i) + then show ?case + by (cases xs) auto +qed + +lemma prepend_ltake_ldrop_id: "prepend (ltake i t) (ldrop i t) = t" + by (induct i arbitrary: t) (auto split: llist.splits) + +context distributed_system +begin + +coinductive cotrace where + cotr_init: "cotrace c LNil" + | cotr_step: "\ c \ ev \ c'; cotrace c' t \ \ cotrace c (LCons ev t)" + +lemma cotrace_trace: "cotrace c t \ \!c'. trace c (ltake i t) c'" +proof (induct i arbitrary: c t) + case (Suc i) + then show ?case + proof (cases t) + case (LCons ev t') + with Suc(2) obtain c' where "c \ ev \ c'" "cotrace c' t'" + by (auto elim: cotrace.cases) + with Suc(1)[OF \cotrace c' t'\] show ?thesis + by (auto simp: LCons elim: trace.intros(2) elim: trace.cases trace_and_start_determines_end) + qed (auto intro: trace.intros elim: trace.cases) +qed (auto simp: zero_enat_def[symmetric] intro: trace.intros elim: trace.cases) + +lemma cotrace_trace': "cotrace c t \ \c'. trace c (ltake i t) c'" + by (metis cotrace_trace) + +definition cos where "cos c t i = s c (ltake i t) i" + +lemma cotrace_trace_cos: "cotrace c t \ trace c (ltake i t) (cos c t i)" + unfolding cos_def s_def + by (subst take_ltake, auto dest!: cotrace_trace[of _ _ i] elim!: theI') + +lemma s_0[simp]: "s c t 0 = c" + unfolding s_def + by (auto intro!: the_equality[where P = "trace c []"] trace.intros elim: trace.cases) + +lemma s_chop: "i \ length t \ s c t i = s c (take i t) i" + unfolding s_def + by auto + +lemma cotrace_prepend: "trace c t c' \ cotrace c' u \ cotrace c (prepend t u)" + by (induct c t c' rule: trace.induct) (auto intro: cotrace.intros) + +lemma s_Cons: "\c''. trace c' xs c'' \ c \ ev \ c' \ s c (ev # xs) (Suc i) = s c' xs i" + by (smt exists_trace_for_any_i take_Suc_Cons tr_step trace_and_start_determines_end) + +lemma cotrace_ldrop: "cotrace c t \ i \ llength t \ cotrace (cos c t i) (ldrop i t)" +proof (induct i arbitrary: c t) + case (Suc i) + then show ?case + proof (cases t) + case (LCons ev t') + with Suc(2) obtain c' where "c \ ev \ c'" "cotrace c' t'" + by (auto elim: cotrace.cases) + with Suc(1)[OF \cotrace c' t'\] Suc(3) show ?thesis + by (auto simp: LCons cos_def eSuc_enat[symmetric] s_chop[symmetric] s_Cons[OF cotrace_trace']) + qed (auto intro: cotrace.intros) +qed (auto simp: zero_enat_def[symmetric] cos_def intro: cotrace.intros) + +end + +locale cocomputation = distributed_system + + fixes + init :: "('a, 'b, 'c) configuration" + assumes + finite_channels: + "finite {i. \p q. channel i = Some (p, q)}" and + strongly_connected_raw: + "\p q. (p \ q) \ + (tranclp (\p q. (\i. channel i = Some (p, q)))) p q" and + + at_least_two_processes: + "card (UNIV :: 'a set) > 1" and + finite_processes: + "finite (UNIV :: 'a set)" and + + no_initial_Marker: + "\i. (\p q. channel i = Some (p, q)) + \ Marker \ set (msgs init i)" and + no_msgs_if_no_channel: + "\i. channel i = None \ msgs init i = []" and + no_initial_process_snapshot: + "\p. \ has_snapshotted init p" and + no_initial_channel_snapshot: + "\i. channel_snapshot init i = ([], NotStarted)" and + + valid: "\t. cotrace init t" and + l1: "\t i cid. cotrace init t + \ Marker \ set (msgs (cos init t i) cid) + \ (\j \ llength t. j \ i \ Marker \ set (msgs (cos init t j) cid))" and + l2: "\t p. cotrace init t + \ (\i \ llength t. has_snapshotted (cos init t i) p)" +begin + +abbreviation coS where "coS \ cos init" + +definition "some_snapshot t p = (SOME i. has_snapshotted (coS t i) p \ i \ llength t)" + +lemma has_snapshotted: + "cotrace init t \ has_snapshotted (coS t (some_snapshot t p)) p \ some_snapshot t p \ llength t" + unfolding some_snapshot_def by (rule someI_ex) (auto dest!: l2[rule_format]) + +lemma cotrace_cos: "cotrace init t \ j < llength t \ + (coS t j) \ lnth t j \ (coS t (Suc j))" + apply (drule cotrace_trace_cos[of _ _ "Suc j"]) + apply (drule step_Suc[rotated, of _ _ _ "j"]) + apply (auto split: enat.splits llist.splits) [] + apply (auto simp: s_chop[of j "_ # ltake j _"] cos_def nth_Cons' ltake_LCons lnth_LCons' + take_Cons' take_ltake + split: llist.splits enat.splits if_splits elim: order.strict_trans2[rotated]) + apply (subst (asm) nth_ltake) + apply (auto elim!: order.strict_trans2[rotated]) [] + apply (subst (asm) s_chop[of j "_ # ltake j _"]) + apply (auto simp: take_Cons' take_ltake split: enat.splits) + done + +lemma snapshot_stable: + "cotrace init t \ i \ j \ has_snapshotted (coS t i) p \ has_snapshotted (coS t j) p" + apply (drule cotrace_trace_cos[of _ _ j]) + unfolding cos_def + by (metis exists_trace_for_any_i_j order_refl s_def snapshot_stable take_ltake) + +lemma no_markers_if_all_snapshotted: + "cotrace init t \ i \ j \ \p. has_snapshotted (coS t i) p \ + Marker \ set (msgs (coS t i) c) \ Marker \ set (msgs (coS t j) c)" + apply (drule cotrace_trace_cos[of _ _ j]) + unfolding cos_def + by (metis exists_trace_for_any_i_j no_markers_if_all_snapshotted order_refl s_def take_ltake) + +lemma cotrace_all_have_snapshotted: + assumes "cotrace init t" + shows "\i \ llength t. \p. has_snapshotted (coS t i) p" +proof - + let ?i = "Max (range (some_snapshot t))" + show ?thesis + using has_snapshotted[OF assms] snapshot_stable[OF assms, of "some_snapshot t _" ?i _] + apply (intro exI[of _ ?i]) + apply (auto simp: finite_processes) + apply (cases "llength t"; auto simp: ) + apply (subst Max_le_iff) + apply (auto simp: finite_processes) + apply blast + done +qed + +lemma no_messages_if_no_channel: + assumes "cotrace init t" + shows "channel cid = None \ msgs (coS t i) cid = []" + using no_messages_introduced_if_no_channel[OF assms[THEN cotrace_trace_cos, of i] no_msgs_if_no_channel, of cid i] + by (auto simp: cos_def) + +lemma cotrace_all_have_snapshotted_and_no_markers: + assumes "cotrace init t" + shows "\i \ llength t. (\p. has_snapshotted (coS t i) p) \ + (\c. Marker \ set (msgs (coS t i) c))" +proof - + from cotrace_all_have_snapshotted[OF assms] obtain j :: nat where + j: "j \ llength t" "\p. has_snapshotted (coS t j) p" by blast + from j(2) have *: "has_snapshotted (coS t k) p" if "k \ j" for k p + using snapshot_stable[OF assms, of j k p] that by auto + define C where "C = {c. Marker \ set (msgs (coS t j) c)}" + have "finite C" + using no_messages_if_no_channel[OF assms, of _ j] unfolding C_def + by (intro finite_subset[OF _ finite_channels]) fastforce + define pick where "pick = (\c. SOME k. k \ llength t \ k \ j \ Marker \ set (msgs (coS t k) c))" + { fix c + assume "c \ C" + then have "\k \ llength t. k \ j \ Marker \ set (msgs (coS t k) c)" + using l1[rule_format, of t j c] assms unfolding C_def by blast + then have "pick c \ llength t \ pick c \ j \ Marker \ set (msgs (coS t (pick c)) c)" + unfolding pick_def + by (rule someI_ex) + } note pick = conjunct1[OF this] conjunct1[OF conjunct2[OF this]] conjunct2[OF conjunct2[OF this]] + show ?thesis + proof (cases "C = {}") + case True + with j show ?thesis + by (auto intro!: exI[of _ j] simp: C_def) + next + define m where "m = Max (pick ` C)" + case False + with \finite C\ have m: "m \ pick ` C" "\x \ pick ` C. m \ x" + unfolding m_def by auto + then have "j \ m" using pick(2) by auto + from *[OF \j \ m\] have "Marker \ set (msgs (coS t m) c)" for c + proof (cases "c \ C") + case True + then show ?thesis + using no_markers_if_all_snapshotted[OF assms, of "pick c" m c] pick[of c] m * + by auto + next + case False + then show ?thesis + using no_markers_if_all_snapshotted[OF assms \j \ m\ j(2), of c] + by (auto simp: C_def) + qed + with *[OF \j \ m\] m pick show ?thesis by auto + qed +qed + +context + fixes t + assumes cotrace: "cotrace init t" +begin + +definition "final_i \ + (SOME i. i \ llength t \ (\p. has_snapshotted (coS t i) p) \ (\c. Marker \ set (msgs (coS t i) c)))" + +definition final where + "final = coS t final_i" + +lemma final_i: "final_i \ llength t" "(\p. has_snapshotted (coS t final_i) p)" "(\c. Marker \ set (msgs (coS t final_i) c))" + unfolding final_i_def + by (rule someI2_ex[OF cotrace_all_have_snapshotted_and_no_markers[OF cotrace]]; auto intro: cotrace_trace_cos[OF cotrace])+ + +lemma final: "\t. trace init t final" "(\p. has_snapshotted final p)" "(\c. Marker \ set (msgs final c))" + unfolding final_def + by (rule cotrace_trace_cos[OF cotrace] final_i exI)+ + +interpretation computation channel trans send recv init final + apply standard + apply (rule finite_channels) + apply (rule strongly_connected_raw) + apply (rule at_least_two_processes) + apply (rule finite_processes) + apply (rule no_initial_Marker) + apply (rule no_msgs_if_no_channel) + apply (rule no_initial_process_snapshot) + apply (rule no_initial_channel_snapshot) + apply (rule final(1)) + apply (intro allI impI) + subgoal for t i cid + apply (rule exI[of _ "length t"]) + apply (metis exists_trace_for_any_i final(3) le_cases take_all trace_and_start_determines_end) + done + apply (intro allI impI) + subgoal for t p + apply (rule exI[of _ "length t"]) + apply (metis exists_trace_for_any_i final(2) order_refl take_all trace_and_start_determines_end) + done + done + +definition coperm where + "coperm l r = (\xs ys z. perm xs ys \ l = prepend xs z \ r = prepend ys z)" + +lemma copermIL: "perm ys xs \ t = prepend xs z \ coperm (prepend ys z) t" + unfolding coperm_def by auto + +lemma snapshot_algorithm_is_cocorrect: + "\t' i. cotrace init t' \ coperm t' t \ state_equal_to_snapshot (coS t' i) final \ i \ final_i" +proof - + define prefix where "prefix = ltake final_i t" + define suffix where "suffix = ldrop final_i t" + have [simp]: "prepend prefix suffix = t" + unfolding prefix_def suffix_def prepend_ltake_ldrop_id .. + have [simp]: "cotrace final suffix" + unfolding suffix_def final_def + by (auto simp: cotrace final_i(1) intro!: cotrace_ldrop) + from cotrace_trace_cos[OF cotrace] have "trace init prefix final" + unfolding final_def prefix_def by blast + with snapshot_algorithm_is_correct obtain prefix' i where + "trace init prefix' final" "perm prefix' prefix" "state_equal_to_snapshot (S prefix' i) final" + "i \ length prefix'" + by blast + moreover from \perm prefix' prefix\ \i \ length prefix'\ have "i \ final_i" + by (auto dest!: perm_length simp: prefix_def split: enat.splits) + ultimately show ?thesis + by (intro exI[of _ "prepend prefix' suffix"] exI[of _ i]) + (auto simp: cos_def ltake_prepend s_chop[symmetric] intro!: cotrace_prepend elim!: copermIL) +qed + +end + +print_statement snapshot_algorithm_is_cocorrect + +end + +end diff --git a/thys/Chandy_Lamport/Distributed_System.thy b/thys/Chandy_Lamport/Distributed_System.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Distributed_System.thy @@ -0,0 +1,1829 @@ +section \Modelling distributed systems\ + +text \We assume familiarity with Chandy and Lamport's +paper \emph{Distributed Snapshots: Determining Global States of +Distributed Systems}~\cite{chandy}.\ + +theory Distributed_System + +imports Main + +begin + +type_synonym 'a fifo = "'a list" +type_synonym channel_id = nat + +datatype 'm message = + Marker + | Msg 'm + +datatype recording_state = + NotStarted + | Recording + | Done + +text \We characterize distributed systems by three underlying type variables: +Type variable 'p captures the processes of the underlying system. +Type variable 's describes the possible states of the processes. +Finally, type variable 'm describes all possible messages in said system. + +Each process is in exactly one state at any point in time of the system. +Processes are interconnected by directed channels, which hold messages in-flight +between connected processes. There can be an arbitrary number of channels between +different processes. The entire state of the system including the (potentially unfinished) +snapshot state is called \emph{configuration}.\ + +record ('p, 's, 'm) configuration = + states :: "'p \ 's" + msgs :: "channel_id \ 'm message fifo" + + process_snapshot :: "'p \ 's option" + channel_snapshot :: "channel_id \ 'm fifo * recording_state" + +text \An event in Chandy and Lamport's formalization describes a +process' state transition, optionally producing or consuming +(but not both) a message on a channel. Additionally, a process may either initiate +a snapshot spontaneously, or is forced to do so by receiving a snapshot \emph{marker} +on one of it's incoming channels.\ + +datatype ('p, 's, 'm) event = + isTrans: Trans (occurs_on: 'p) 's 's + | isSend: Send (getId: channel_id) + (occurs_on: 'p) + (partner: 'p) + 's 's (getMsg: 'm) + | isRecv: Recv (getId: channel_id) + (occurs_on: 'p) + (partner: 'p) + 's 's (getMsg: 'm) + + | isSnapshot: Snapshot (occurs_on: 'p) + | isRecvMarker: RecvMarker (getId: channel_id) + (occurs_on: 'p) + (partner: 'p) + +text \We introduce abbreviations and type synoyms for commonly used terms.\ + +type_synonym ('p, 's, 'm) trace = "('p, 's, 'm) event list" + +abbreviation ps where "ps \ process_snapshot" +abbreviation cs where "cs \ channel_snapshot" + +abbreviation no_snapshot_change where + "no_snapshot_change c c' \ ((\p'. ps c p' = ps c' p') \ (\i'. cs c i' = cs c' i'))" + +abbreviation has_snapshotted where + "has_snapshotted c p \ process_snapshot c p \ None" + +text \A regular event is an event as described in Chandy and Lamport's +original paper: A state transition accompanied by the emission +or receiving of a message. Nonregular events are related to +snapshotting and receiving markers along communication channels.\ + +definition regular_event[simp]: + "regular_event ev \ (isTrans ev \ isSend ev \ isRecv ev)" + +lemma nonregular_event: + "~ regular_event ev = (isSnapshot ev \ isRecvMarker ev)" + by (meson event.distinct_disc event.exhaust_disc regular_event) + +lemma event_occurs_on_unique: + assumes + "p \ q" + "occurs_on ev = p" + shows + "occurs_on ev \ q" + using assms by (cases ev, auto) + +subsection \The distributed system locale\ + +text \In order to capture Chandy and Lamport's computation system +we introduce two locales. The distributed system locale describes +global truths, such as the mapping from channel IDs to sender and +receiver processes, the transition relations for the underlying +computation system and the core assumption that no process has +a channel to itself. While not explicitly mentioned in Chandy's +and Lamport's work, it makes sense to assume that a channel need +not communicate to itself via messages, since it shares memory with +itself.\ + +locale distributed_system = + fixes + channel :: "channel_id \ ('p * 'p) option" and + trans :: "'p \ 's \ 's \ bool" and + send :: "channel_id \ 'p \ 'p \ 's \ 's \ 'm \ bool" and + recv :: "channel_id \ 'p \ 'p \ 's \ 's \ 'm \ bool" + assumes + no_self_channel: + "\i. \p. channel i = Some (p, p)" +begin + +subsubsection \State transitions\ + +definition can_occur :: "('p, 's, 'm) event \ ('p, 's, 'm) configuration \ bool" where +"can_occur ev c \ (case ev of + Trans p s s' \ states c p = s + \ trans p s s' + | Send i p q s s' msg \ states c p = s + \ channel i = Some (p, q) + \ send i p q s s' msg + | Recv i p q s s' msg \ states c p = s + \ channel i = Some (q, p) + \ length (msgs c i) > 0 + \ hd (msgs c i) = Msg msg + \ recv i p q s s' msg + | Snapshot p \ \ has_snapshotted c p + | RecvMarker i p q \ channel i = Some (q, p) + \ length (msgs c i) > 0 + \ hd (msgs c i) = Marker)" + +definition src where + "src i p \ (\q. channel i = Some (p, q))" + +definition dest where + "dest i q \ (\p. channel i = Some (p, q))" + +lemma can_occur_Recv: + assumes + "can_occur (Recv i p q s s' m) c" + shows + "states c p = s \ channel i = Some (q, p) \ (\xs. msgs c i = Msg m # xs) \ recv i p q s s' m" +proof - + have "\xs. msgs c i = Msg m # xs" + using assms can_occur_def + by (metis (mono_tags, lifting) event.case(3) hd_Cons_tl length_greater_0_conv) + then show ?thesis using assms can_occur_def by auto +qed + +abbreviation check_snapshot_occur where + "check_snapshot_occur c c' p \ + (can_occur (Snapshot p) c \ + (ps c' p = Some (states c p)) + \ (\p'. states c p' = states c' p') + \ (\p'. (p' \ p) \ ps c' p' = ps c p') + \ (\i. (\q. channel i = Some (p, q)) \ msgs c' i = msgs c i @ [Marker]) + \ (\i. (\q. channel i = Some (q, p)) \ channel_snapshot c' i = (fst (channel_snapshot c i), Recording)) + \ (\i. (\q. channel i = Some (p, q)) \ msgs c' i = msgs c i) + \ (\i. (\q. channel i = Some (q, p)) \ channel_snapshot c' i = channel_snapshot c i))" + +abbreviation check_recv_marker_occur where + "check_recv_marker_occur c c' i p q \ + (can_occur (RecvMarker i p q) c + \ (\r. states c r = states c' r) + \ (\r. (r \ p) \ process_snapshot c r = process_snapshot c' r) + \ (Marker # msgs c' i = msgs c i) + \ (channel_snapshot c' i = (fst (channel_snapshot c i), Done)) + \ (if has_snapshotted c p + then (process_snapshot c p = process_snapshot c' p) + \ (\i'. (i' \ i) \ msgs c' i' = msgs c i') + \ (\i'. (i' \ i) \ channel_snapshot c i' = channel_snapshot c' i') + else (process_snapshot c' p = Some (states c p)) + \ (\i'. i' \ i \ (\r. channel i' = Some (p, r)) + \ msgs c' i' = msgs c i' @ [Marker]) + \ (\i'. i' \ i \ (\r. channel i' = Some (r, p)) + \ channel_snapshot c' i' = (fst (channel_snapshot c i'), Recording)) + \ (\i'. i' \ i \ (\r. channel i' = Some (p, r)) + \ msgs c' i' = msgs c i') + \ (\i'. i' \ i \ (\r. channel i' = Some (r, p)) + \ channel_snapshot c' i' = channel_snapshot c i')))" + +abbreviation check_trans_occur where + "check_trans_occur c c' p s s'\ + (can_occur (Trans p s s') c + \ (states c' p = s') + \ (\r. (r \ p) \ states c' r = states c r) + \ (\i. msgs c' i = msgs c i) + \ (no_snapshot_change c c'))" + +abbreviation check_send_occur where + "check_send_occur c c' i p q s s' msg \ + (can_occur (Send i p q s s' msg) c + \ (states c' p = s') + \ (\r. (r \ p) \ states c' r = states c r) + \ (msgs c' i = msgs c i @ [Msg msg]) + \ (\i'. i \ i' \ msgs c' i' = msgs c i') + \ (no_snapshot_change c c'))" + +abbreviation check_recv_occur where + "check_recv_occur c c' i p q s s' msg \ + (can_occur (Recv i p q s s' msg) c + \ (states c p = s \ states c' p = s') + \ (\r. (r \ p) \ states c' r = states c r) + \ (msgs c i = Msg msg # msgs c' i) + \ (\i'. i \ i' \ msgs c' i' = msgs c i') + \ (\r. process_snapshot c r = process_snapshot c' r) + \ (\i'. i' \ i \ channel_snapshot c i' = channel_snapshot c' i') + \ (if snd (channel_snapshot c i) = Recording + then channel_snapshot c' i = (fst (channel_snapshot c i) @ [msg], Recording) + else channel_snapshot c i = channel_snapshot c' i))" + +text \The \emph{next} predicate lets us express configuration transitions +using events. The predicate $next(s_1, e, s_2)$ denotes the transition +of the configuration $s_1$ to $s_2$ via the event $e$. It ensures that +$e$ can occur in state $s_1$ and the state $s_2$ is correctly constructed +from $s_1$.\ + +primrec "next" :: + "('p, 's, 'm) configuration + \ ('p, 's, 'm) event + \ ('p, 's, 'm) configuration + \ bool" + ("_ \ _ \ _" [70, 70, 70]) where + next_snapshot: "c \ Snapshot p \ c' = + check_snapshot_occur c c' p" + | next_recv_marker: "c \ RecvMarker i p q \ c' = + check_recv_marker_occur c c' i p q" + | next_trans: "c \ Trans p s s' \ c' = + check_trans_occur c c' p s s'" + | next_send: "c \ Send i p q s s' msg \ c' = + check_send_occur c c' i p q s s' msg" + | next_recv: "c \ Recv i p q s s' msg \ c' = + check_recv_occur c c' i p q s s' msg" + +text \Useful lemmas about state transitions\ + +lemma state_and_event_determine_next: + assumes + "c \ ev \ c'" and + "c \ ev \ c''" + shows + "c' = c''" +proof (cases ev) + case (Snapshot p) + then have "states c' = states c''" using assms by auto + moreover have "msgs c' = msgs c''" + proof (rule ext) + fix i + show "msgs c' i = msgs c'' i" + proof (cases "channel i = None") + case True + then show ?thesis using Snapshot assms by auto + next + case False + then obtain r s where "channel i = Some (r, s)" by auto + with assms Snapshot show ?thesis by (cases "r = p", simp_all) + qed + qed + moreover have "process_snapshot c' = process_snapshot c''" by (metis Snapshot assms next_snapshot ext) + moreover have "channel_snapshot c' = channel_snapshot c''" + proof (rule ext) + fix i + show "channel_snapshot c' i = channel_snapshot c'' i" + proof (cases "channel i = None") + case True + then show ?thesis using assms Snapshot by simp + next + case False + then obtain r s where "channel i = Some (r, s)" by auto + with assms Snapshot show ?thesis by (cases "s = p", simp_all) + qed + qed + ultimately show "c' = c''" by simp +next + case (RecvMarker i p) + then have "states c' = states c''" using assms by auto + moreover have "msgs c' = msgs c''" + proof (rule ext) + fix i' + show "msgs c' i' = msgs c'' i'" + proof (cases "i' = i") + case True + then have "Marker # msgs c' i' = msgs c i'" using assms RecvMarker by simp + also have "... = Marker # msgs c'' i'" using assms RecvMarker `i' = i` by simp + finally show ?thesis by simp + next + case False + then show ?thesis + proof (cases "has_snapshotted c p") + case True + then show ?thesis using assms RecvMarker `i' \ i` by simp + next + case no_snap: False + then show ?thesis + proof (cases "channel i' = None") + case True + then show ?thesis using assms RecvMarker `i' \ i` no_snap by simp + next + case False + then obtain r s where "channel i' = Some (r, s)" by auto + with assms RecvMarker no_snap `i' \ i` show ?thesis by (cases "r = p"; simp_all) + qed + qed + qed + qed + moreover have "process_snapshot c' = process_snapshot c''" + proof (rule ext) + fix r + show "ps c' r = ps c'' r" + proof (cases "r \ p") + case True + then show ?thesis using assms RecvMarker by simp + next + case False + with assms RecvMarker `~ r \ p` show ?thesis by (cases "has_snapshotted c r", auto) + qed + qed + moreover have "channel_snapshot c' = channel_snapshot c''" + proof (rule ext) + fix i' + show "cs c' i' = cs c'' i'" + proof (cases "i' = i") + case True + then show ?thesis using assms RecvMarker by simp + next + case False + then show ?thesis + proof (cases "has_snapshotted c p") + case True + then show ?thesis using assms RecvMarker `i' \ i` by simp + next + case no_snap: False + then show ?thesis + proof (cases "channel i' = None") + case True + then show ?thesis using assms RecvMarker `i' \ i` no_snap by simp + next + case False + then obtain r s where "channel i' = Some (r, s)" by auto + with assms RecvMarker no_snap `i' \ i` show ?thesis by (cases "s = p"; simp_all) + qed + qed + qed + qed + ultimately show "c' = c''" by simp +next + case (Trans p s s') + then have "states c' = states c''" by (metis (no_types, lifting) assms next_trans ext) + moreover have "msgs c' = msgs c''" using assms Trans by auto + moreover have "process_snapshot c' = process_snapshot c''" using assms Trans by auto + moreover have "channel_snapshot c' = channel_snapshot c''" using assms Trans by auto + ultimately show "c' = c''" by simp +next + case (Send i p s s' m) + then have "states c' = states c''" by (metis (no_types, lifting) assms next_send ext) + moreover have "msgs c' = msgs c''" + proof (rule ext) + fix i' + from assms Send show "msgs c' i' = msgs c'' i'" by (cases "i' = i", simp_all) + qed + moreover have "process_snapshot c' = process_snapshot c''" using assms Send by auto + moreover have "channel_snapshot c' = channel_snapshot c''" using assms Send by auto + ultimately show "c' = c''" by simp +next + case (Recv i p s s' m) + then have "states c' = states c''" by (metis (no_types, lifting) assms next_recv ext) + moreover have "msgs c' = msgs c''" + proof (rule ext) + fix i' + from assms Recv show "msgs c' i' = msgs c'' i'" by (cases "i' = i", simp_all) + qed + moreover have "process_snapshot c' = process_snapshot c''" using assms Recv by auto + moreover have "channel_snapshot c' = channel_snapshot c''" + proof (rule ext) + fix i' + show "cs c' i' = cs c'' i'" + proof (cases "i' \ i") + case True + then show ?thesis using assms Recv by simp + next + case False + with assms Recv show ?thesis by (cases "snd (cs c i') = Recording", auto) + qed + qed + ultimately show "c' = c''" by simp +qed + +lemma exists_next_if_can_occur: + assumes + "can_occur ev c" + shows + "\c'. c \ ev \ c'" +proof (cases ev) + case (Snapshot p) + let ?c = "\ states = states c, + msgs = %i. if (\q. channel i = Some (p, q)) then msgs c i @ [Marker] else msgs c i, + process_snapshot = %r. if r = p then Some (states c p) else ps c r, + channel_snapshot = %i. if (\q. channel i = Some (q, p)) then (fst (cs c i), Recording) else cs c i \" + have "c \ ev \ ?c" using Snapshot assms by auto + then show ?thesis by blast +next + case (RecvMarker i p q) + show ?thesis + proof (cases "has_snapshotted c p") + case True + let ?c = "\ states = states c, + msgs = %i'. if i = i' then tl (msgs c i') else msgs c i', + process_snapshot = ps c, + channel_snapshot = %i'. if i = i' then (fst (cs c i'), Done) else cs c i' \" + have "msgs c i = Marker # msgs ?c i" + using assms can_occur_def RecvMarker hd_Cons_tl by fastforce + then have "c \ ev \ ?c" using True RecvMarker assms by auto + then show ?thesis by blast + next + case False + let ?c = "\ states = states c, + msgs = %i'. if i' = i + then tl (msgs c i') + else if (\r. channel i' = Some (p, r)) + then msgs c i' @ [Marker] + else msgs c i', + process_snapshot = %r. if r = p then Some (states c r) else ps c r, + channel_snapshot = %i'. if i = i' then (fst (cs c i'), Done) + else if (\r. channel i' = Some (r, p)) + then (fst (cs c i'), Recording) + else cs c i' \" + have "msgs c i = Marker # msgs ?c i" + using assms can_occur_def RecvMarker hd_Cons_tl by fastforce + moreover have "ps ?c p = Some (states c p)" by simp + ultimately have "c \ ev \ ?c" using RecvMarker assms False by auto + then show ?thesis by blast + qed +next + case (Trans p s s') + let ?c = "\ states = %r. if r = p then s' else states c r, + msgs = msgs c, + process_snapshot = ps c, + channel_snapshot = cs c \" + have "c \ ev \ ?c" + using Trans assms by auto + then show ?thesis by blast +next + case (Send i p q s s' msg) + let ?c = "\ states = %r. if r = p then s' else states c r, + msgs = %i'. if i = i' then msgs c i' @ [Msg msg] else msgs c i', + process_snapshot = ps c, + channel_snapshot = cs c \" + have "c \ ev \ ?c" + using Send assms by auto + then show ?thesis by blast +next + case (Recv i p q s s' msg) + then show ?thesis + proof (cases "snd (cs c i)") + case Recording + let ?c = "\ states = %r. if r = p then s' else states c r, + msgs = %i'. if i = i' then tl (msgs c i') else msgs c i', + process_snapshot = ps c, + channel_snapshot = %i'. if i = i' + then (fst (cs c i') @ [msg], Recording) + else cs c i'\" + have "c \ ev \ ?c" + using Recv Recording assms can_occur_Recv by fastforce + then show ?thesis by blast + next + case Done + let ?c = "\ states = %r. if r = p then s' else states c r, + msgs = %i'. if i = i' then tl (msgs c i') else msgs c i', + process_snapshot = ps c, + channel_snapshot = cs c \" + have "c \ ev \ ?c" + using Done Recv assms can_occur_Recv by fastforce + then show ?thesis by blast + next + case NotStarted + let ?c = "\ states = %r. if r = p then s' else states c r, + msgs = %i'. if i = i' then tl (msgs c i') else msgs c i', + process_snapshot = ps c, + channel_snapshot = cs c \" + have "c \ ev \ ?c" + using NotStarted Recv assms can_occur_Recv by fastforce + then show ?thesis by blast + qed +qed + +lemma exists_exactly_one_following_state: + "can_occur ev c \ \!c'. c \ ev \ c'" + using exists_next_if_can_occur state_and_event_determine_next by blast + +lemma no_state_change_if_no_event: + assumes + "c \ ev \ c'" and + "occurs_on ev \ p" + shows + "states c p = states c' p \ process_snapshot c p = process_snapshot c' p" + using assms by (cases ev, auto) + +lemma no_msgs_change_if_no_channel: + assumes + "c \ ev \ c'" and + "channel i = None" + shows + "msgs c i = msgs c' i" +using assms proof (cases ev) + case (RecvMarker cid p) + then have "cid \ i" using assms RecvMarker can_occur_def by fastforce + with assms RecvMarker show ?thesis by (cases "has_snapshotted c p", auto) +next + case (Send cid p s s' m) + then have "cid \ i" using assms Send can_occur_def by fastforce + then show ?thesis using assms Send by auto +next + case (Recv cid p s s' m) + then have "cid \ i" using assms Recv can_occur_def by fastforce + then show ?thesis using assms Recv by simp +qed simp_all + +lemma no_cs_change_if_no_channel: + assumes + "c \ ev \ c'" and + "channel i = None" + shows + "cs c i = cs c' i" +using assms proof (cases ev) + case (RecvMarker cid p) + then have "cid \ i" using assms RecvMarker can_occur_def by fastforce + with assms RecvMarker show ?thesis by (cases "has_snapshotted c p", auto) +next + case (Send cid p s s' m) + then have "cid \ i" using assms Send can_occur_def by fastforce + then show ?thesis using assms Send by auto +next + case (Recv cid p s s' m) + then have "cid \ i" using assms Recv can_occur_def by fastforce + then show ?thesis using assms Recv by simp +qed simp_all + +lemma no_msg_change_if_no_event: + assumes + "c \ ev \ c'" and + "isSend ev \ getId ev \ i" and + "isRecv ev \ getId ev \ i" and + "regular_event ev" + shows + "msgs c i = msgs c' i" +proof (cases "channel i = None") + case True + then show ?thesis using assms no_msgs_change_if_no_channel by simp +next + have "isTrans ev \ isSend ev \ isRecv ev" using assms by simp + then show ?thesis + proof (elim disjE) + assume "isTrans ev" + then show ?thesis + by (metis assms(1) event.collapse(1) next_trans) + next + assume "isSend ev" + then obtain i' r s u u' m where Send: "ev = Send i' r s u u' m" by (meson isSend_def) + then show ?thesis using Send assms by auto + next + assume "isRecv ev" + then obtain i' r s u u' m where "ev = Recv i' r s u u' m" by (meson isRecv_def) + then show ?thesis using assms by auto + qed +qed + +lemma no_cs_change_if_no_event: + assumes + "c \ ev \ c'" and + "isRecv ev \ getId ev \ i" and + "regular_event ev" + shows + "cs c i = cs c' i" +proof - + have "isTrans ev \ isSend ev \ isRecv ev" using assms by simp + then show ?thesis + proof (elim disjE) + assume "isTrans ev" + then show ?thesis + by (metis assms(1) event.collapse(1) next_trans) + next + assume "isSend ev" + then obtain i' r s u u' m where "ev = Send i' r s u u' m" by (meson isSend_def) + then show ?thesis using assms by auto + next + assume "isRecv ev" + then obtain i r s u u' m where "ev = Recv i r s u u' m" by (meson isRecv_def) + then show ?thesis using assms by auto + qed +qed + +lemma happen_implies_can_occur: + assumes + "c \ ev \ c'" + shows + "can_occur ev c" +proof - + show ?thesis using assms by (cases ev, auto) +qed + +lemma snapshot_increases_message_length: + assumes + "ev = Snapshot p" and + "c \ ev \ c'" and + "channel i = Some (q, r)" + shows + "length (msgs c i) \ length (msgs c' i)" + using assms by (cases "p = q", auto) + +lemma recv_marker_changes_head_only_at_i: + assumes + "ev = RecvMarker i p q" and + "c \ ev \ c'" and + "i' \ i" + shows + "msgs c i' = [] \ hd (msgs c i') = hd (msgs c' i')" +proof (cases "channel i' = None") + case True + then show ?thesis using assms no_msgs_change_if_no_channel by presburger +next + case False + then show ?thesis + proof (cases "msgs c i'") + case Nil + then show ?thesis by simp + next + case (Cons m xs) + then obtain r s where "channel i' = Some (r, s)" using False by auto + then show ?thesis + proof (cases "has_snapshotted c p") + case True + then show ?thesis using assms by auto + next + case False + with assms show ?thesis by (cases "r = p", auto) + qed + qed +qed + +lemma recv_marker_other_channels_not_shrinking: + assumes + "ev = RecvMarker i p q" and + "c \ ev \ c'" + shows + "length (msgs c i') \ length (msgs c' i') \ i \ i'" +proof (rule iffI) + show "length (msgs c i') \ length (msgs c' i') \ i \ i'" + proof (rule ccontr) + assume asm: "~ i \ i'" "length (msgs c i') \ length (msgs c' i')" + then have "msgs c i = Marker # msgs c' i" using assms by auto + then have "length (msgs c i) > length (msgs c' i)" by simp + then have "length (msgs c i') > length (msgs c' i')" using asm by simp + then show False using asm by simp + qed +next + show "i \ i' \ length (msgs c i') \ length (msgs c' i')" + proof - + assume "i \ i'" + then show ?thesis + proof (cases "channel i' = None") + case True + then show ?thesis using assms no_msgs_change_if_no_channel by presburger + next + case False + then obtain r s where chan: "channel i' = Some (r, s)" by auto + then show ?thesis + proof (cases "has_snapshotted c p") + case True + with assms `i \ i'` show ?thesis by auto + next + case no_snap: False + then show ?thesis + proof (cases "p = r") + case True + then have "msgs c' i' = msgs c i' @ [Marker]" using `i \ i'` assms no_snap chan by auto + then show ?thesis by auto + next + case False + then show ?thesis using assms `i \ i'` chan no_snap by auto + qed + qed + qed + qed +qed + +lemma regular_event_cannot_induce_snapshot: + assumes + "~ has_snapshotted c p" and + "c \ ev \ c'" + shows + "regular_event ev \ ~ has_snapshotted c' p" +proof (cases ev) + case (Trans q s s') + then show ?thesis using assms(1) assms(2) by auto +next + case (Send q r s s' m) + then show ?thesis using assms by auto +next + case (Recv q r s s' m) + then show ?thesis using assms by auto +qed simp_all + +lemma regular_event_preserves_process_snapshots: + assumes + "c \ ev \ c'" + shows + "regular_event ev \ ps c r = ps c' r" +proof (cases ev) + case (Trans p s s') + then show ?thesis + using assms by auto +next + case (Send p q s s' m) + then show ?thesis + using assms by auto +next + case (Recv p q s s' m) + then show ?thesis + using assms by auto +qed simp_all + +lemma no_state_change_if_nonregular_event: + assumes + "~ regular_event ev" and + "c \ ev \ c'" + shows + "states c p = states c' p" +proof - + have "isSnapshot ev \ isRecvMarker ev" using nonregular_event assms by auto + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then obtain q where "ev = Snapshot q" + by (meson isSnapshot_def) + then show ?thesis + using assms(2) by auto + next + case 2 + then obtain i q r where "ev = RecvMarker i q r" + by (meson isRecvMarker_def) + then show ?thesis using assms(2) by auto + qed +qed + +lemma nonregular_event_induces_snapshot: + assumes + "~ has_snapshotted c p" and + "c \ ev \ c'" and + "occurs_on ev = p" and + "~ regular_event ev" + shows + "~ regular_event ev \ has_snapshotted c' p" +proof (cases ev) + case (Snapshot q) + then have "q = p" using assms by auto + then show ?thesis using Snapshot assms(2) by auto +next + case (RecvMarker i q r) + then have "q = p" using assms by auto + then show ?thesis using RecvMarker assms by auto +qed (simp_all add: assms) + +lemma snapshot_state_unchanged: + assumes + step: "c \ ev \ c'" and + "has_snapshotted c p" + shows + "ps c p = ps c' p" +proof (cases "occurs_on ev = p") + case False + then show ?thesis + using local.step no_state_change_if_no_event by auto +next + case True + then show ?thesis + proof (cases "regular_event ev") + case True + then show ?thesis + using local.step regular_event_preserves_process_snapshots by auto + next + case False + have "isRecvMarker ev" + proof (rule ccontr) + have "isSnapshot ev \ isRecvMarker ev" + using False nonregular_event by blast + moreover assume "~ isRecvMarker ev" + ultimately have "isSnapshot ev" by simp + then have "ev = Snapshot p" by (metis True event.collapse(4)) + then have "can_occur ev c" + using happen_implies_can_occur local.step by blast + then have "~ has_snapshotted c p" unfolding can_occur_def + by (simp add: \ev = Snapshot p\) + then show False using assms by auto + qed + then show ?thesis (* z3 sledgehammer fails for Isabelle2019 *) + proof - + have "\n pa. c \ RecvMarker n p pa \ c'" + by (metis True \isRecvMarker ev\ event.collapse(5) local.step) + then show ?thesis + using assms(2) by force + qed + qed +qed + +lemma message_must_be_delivered: + assumes + valid: "c \ ev \ c'" and + delivered: "(msgs c i \ [] \ hd (msgs c i) = m) \ (msgs c' i = [] \ hd (msgs c' i) \ m)" + shows + "(\p q. ev = RecvMarker i p q \ m = Marker) + \ (\p q s s' m'. ev = Recv i p q s s' m' \ m = Msg m')" +proof (cases ev) + case (Snapshot p) + then show ?thesis + proof (cases "msgs c i") + case Nil + then show ?thesis using delivered by simp + next + case (Cons m xs) + with assms Snapshot show ?thesis + proof (cases "channel i = None") + case True + then show ?thesis using assms Snapshot by auto + next + case False + then obtain r s where chan: "channel i = Some (r, s)" by auto + then show ?thesis + proof (cases "r = p") + case True + then have "msgs c' i = msgs c i @ [Marker]" using assms(1) Snapshot chan by auto + then show ?thesis using delivered by auto + next + case False + then have "msgs c' i = msgs c i" using assms Snapshot chan by simp + then show ?thesis using delivered Cons by simp + qed + qed + qed +next + case (RecvMarker i' p q) + then have "i' = i" + by (metis assms(1) delivered le_0_eq length_greater_0_conv list.size(3) recv_marker_changes_head_only_at_i recv_marker_other_channels_not_shrinking) + moreover have "Marker = m" + using `i' = i` RecvMarker assms(1) can_occur_def delivered by auto + moreover have "channel i = Some (q, p)" + using RecvMarker assms(1) calculation(1) can_occur_def by auto + ultimately show ?thesis using RecvMarker by simp +next + case (Trans p' s s') + then show ?thesis + using valid delivered by auto +next + case (Send p' q' s s' m') + then show ?thesis + by (metis (no_types, lifting) delivered distributed_system.next.simps(4) distributed_system_axioms hd_append2 snoc_eq_iff_butlast valid) +next + case (Recv i' p q s s' m') + then have "i = i'" + using assms(1) delivered by auto + also have "m = Msg m'" + by (metis (no_types, lifting) Recv delivered list.sel(1) next_recv valid) + ultimately show ?thesis using Recv by auto +qed + +lemma message_must_be_delivered_2: + assumes + "c \ ev \ c'" + "m : set (msgs c i)" + "m \ set (msgs c' i)" + shows + "(\p q. ev = RecvMarker i p q \ m = Marker) \ (\p q s s' m'. ev = Recv i p q s s' m' \ m = Msg m')" +proof - + have uneq_sets: "set (msgs c i) \ set (msgs c' i)" + using assms(2) assms(3) by blast + then obtain p q where chan: "channel i = Some (p, q)" + using assms no_msgs_change_if_no_channel by fastforce + then show ?thesis + proof (cases ev) + case (Snapshot p') + with Snapshot assms chan have "set (msgs c' i) = set (msgs c i)" by (cases "p' = p", auto) + then show ?thesis using uneq_sets by simp + next + case (Trans p' s s') + then show ?thesis using uneq_sets assms by simp + next + case (Send i' p' q' s s' m) + then show ?thesis + by (metis (no_types, lifting) UnCI assms(1) assms(2) assms(3) local.next.simps(4) set_append) + next + case (RecvMarker i' p' q') + have "i' = i" + proof (rule ccontr) + assume "~ i' = i" + show False using assms chan RecvMarker + proof (cases "has_snapshotted c p'") + case True + then show False using assms chan RecvMarker `~ i' = i` by simp + next + case False + then show False using assms chan RecvMarker `~ i' = i` by (cases "p' = p", simp_all) + qed + qed + moreover have "m = Marker" + proof - + have "msgs c i' = Marker # msgs c' i'" using assms chan RecvMarker by auto + then show ?thesis using assms `i' = i` by simp + qed + ultimately show ?thesis using RecvMarker by simp + next + case (Recv i' p' q' s s' m') + have "i' = i" + proof (rule ccontr) + assume "~ i' = i" + then show False + using Recv assms(1) uneq_sets by auto + qed + then have "i' = i \ m = Msg m'" + using Recv assms by auto + then show ?thesis using Recv by simp + qed +qed + +lemma recv_marker_means_snapshotted_1: + assumes + "ev = RecvMarker i p q" and + "c \ ev \ c'" + shows + "has_snapshotted c' p" + using assms snapshot_state_unchanged by (cases "has_snapshotted c p", auto) + +lemma recv_marker_means_snapshotted_2: + fixes + c c' :: "('p, 's, 'm) configuration" and + ev :: "('p, 's, 'm) event" and + i :: channel_id + assumes + "c \ ev \ c'" and + "Marker : set (msgs c i)" and + "Marker \ set (msgs c' i)" and + "channel i = Some (q, p)" + shows + "has_snapshotted c' p" +proof - + have "\p q. ev = RecvMarker i p q" + using assms message_must_be_delivered_2 by blast + then obtain r s where RecvMarker: "ev = RecvMarker i r s" + by blast + then have "r = p" + using assms(1) assms(4) can_occur_def by auto + then show ?thesis + using recv_marker_means_snapshotted_1 assms RecvMarker by blast +qed + +lemma event_stays_valid_if_no_occurrence: + assumes + "c \ ev \ c'" and + "occurs_on ev \ occurs_on ev'" and + "can_occur ev' c" + shows + "can_occur ev' c'" +proof (cases ev') + case (Trans p s s') + have "states c p = states c' p" + using Trans assms(1) assms(2) no_state_change_if_no_event by auto + moreover have "states c p = s" using can_occur_def assms Trans by simp + ultimately have "states c' p = s" by simp + moreover have "trans p s s'" + using Trans assms(3) can_occur_def by auto + ultimately show ?thesis + by (simp add: Trans can_occur_def) +next + case (Recv i p q s s' m) + then have "hd (msgs c i) = Msg m" + proof - + from Recv have "length (msgs c i) > 0" using assms(3) can_occur_def by auto + then obtain m' xs where mcqp: "msgs c i = m' # xs" + by (metis list.size(3) nat_less_le neq_Nil_conv) + then have "Msg m = m'" + proof (cases m', auto) + case Marker + then have "msgs c i = Marker # xs" by (simp add:mcqp) + then have "~ can_occur ev' c" using Recv can_occur_def by simp + then show False using assms(3) by simp + next + case (Msg msg) + then have "msgs c i = Msg msg # xs" by (simp add: mcqp) + then show "m = msg" using Recv can_occur_def assms(3) by simp + qed + then show ?thesis by (simp add: mcqp) + qed + show ?thesis + proof (rule ccontr) + assume asm: "~ can_occur ev' c'" + then have "msgs c' i = [] \ hd (msgs c' i) \ Msg m" + using Recv assms can_occur_def no_state_change_if_no_event distributed_system_axioms list.case_eq_if by fastforce + then obtain i' p' q' s'' s''' m' where RMoR: "ev = RecvMarker i' p' q' \ ev = Recv i p' q' s'' s''' m'" + by (metis Recv \hd (msgs c i) = Msg m\ assms(1) assms(3) can_occur_Recv list.discI message_must_be_delivered) + then have "occurs_on ev = p" + proof - + have f1: "states c p = s \ channel i = Some (q, p) \ recv i p q s s' m \ 0 < length (msgs c i) \ hd (msgs c i) = Msg m" + using Recv assms(3) can_occur_def by force + have f2: "RecvMarker i' p' q' = ev \ states c p' = s'' \ channel i = Some (q', p') \ recv i p' q' s'' s''' m' \ 0 < length (msgs c i) \ hd (msgs c i) = Msg m'" + using RMoR assms(1) can_occur_def by force + have "\e n c. \p pa s sa m. \ca cb. (\ c \ e \ ca \ msgs ca n \ [] \ hd (msgs c n) = Marker \ msgs c n = [] \ Recv n p pa s sa m = e) \ (\ c \ e \ cb \ hd (msgs c n) = Marker \ hd (msgs cb n) = hd (msgs c n) \ msgs c n = [] \ Recv n p pa s sa m = e)" + by (metis (no_types) message_must_be_delivered) + then show ?thesis + using f2 f1 by (metis RMoR \msgs c' i = [] \ hd (msgs c' i) \ Msg m\ assms(1) event.disc(13,15) event.sel(3,5) length_greater_0_conv message.distinct(1) option.inject prod.inject) + qed + then show False using assms Recv by simp + qed +next + case (Send i p q s s' m) + then have "states c p = states c' p" using assms no_state_change_if_no_event by auto + then show "can_occur ev' c'" using assms assms(3) can_occur_def Send by auto +next + case (RecvMarker i p q) + then have msgs_ci: "hd (msgs c i) = Marker \ length (msgs c i) > 0" + proof - + from RecvMarker have "length (msgs c i) > 0" using assms(3) can_occur_def by auto + then obtain m' xs where mci: "msgs c i = m' # xs" + by (metis list.size(3) nat_less_le neq_Nil_conv) + then have m_mark: "Marker = m'" + proof (cases m', auto) + case (Msg msg) + then have "msgs c i = Msg msg # xs" by (simp add:mci) + then have "~ can_occur ev' c" using RecvMarker can_occur_def by simp + then show False using assms(3) by simp + qed + then show ?thesis by (simp add: mci) + qed + show ?thesis + proof (rule ccontr) + assume asm: "~ can_occur ev' c'" + then have "msgs c' i = [] \ hd (msgs c' i) \ Marker" + using RecvMarker assms(3) can_occur_def list.case_eq_if by fastforce + then have "\p q. ev = RecvMarker i p q \ Marker = Marker" using message_must_be_delivered msgs_ci assms by blast + then obtain r s where RecvMarker_ev: "ev = RecvMarker i r s" by blast + then have "p = r \ q = s" + using RecvMarker assms(1) assms(3) can_occur_def by auto + then have "occurs_on ev = p" using assms RecvMarker_ev by auto + then show False using assms using RecvMarker by auto + qed +next + case (Snapshot p) + then have "~ has_snapshotted c p" using assms assms(3) can_occur_def by simp + show ?thesis + proof (rule ccontr) + assume asm: "~ can_occur ev' c'" + then have "has_snapshotted c' p" using can_occur_def Snapshot by simp + then have "occurs_on ev = p" + using \\ has_snapshotted c p\ assms(1) no_state_change_if_no_event by fastforce + then show False using assms(2) Snapshot by auto + qed +qed + +lemma msgs_unchanged_for_other_is: + assumes + "c \ ev \ c'" and + "regular_event ev" and + "getId ev = i" and + "i' \ i" + shows + "msgs c i' = msgs c' i'" +proof - + have "isTrans ev \ isSend ev \ isRecv ev" using assms by simp + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then obtain p s s' where "ev = Trans p s s'" by (meson isTrans_def) + then show ?thesis using assms by simp + next + case 2 + then obtain i' p q s s' m where "ev = Send i' p q s s' m" by (meson isSend_def) + then show ?thesis using assms by simp + next + case 3 + then obtain i' p q s s' m where "ev = Recv i' p q s s' m" by (meson isRecv_def) + with assms show ?thesis by auto + qed +qed + +lemma msgs_unchanged_if_snapshotted_RecvMarker_for_other_is: + assumes + "c \ ev \ c'" and + "ev = RecvMarker i p q" and + "has_snapshotted c p" and + "i' \ i" + shows + "msgs c i' = msgs c' i'" + using assms by auto + +lemma event_can_go_back_if_no_sender: + assumes + "c \ ev \ c'" and + "occurs_on ev \ occurs_on ev'" and + "can_occur ev' c'" and + "~ isRecvMarker ev'" and + "~ isSend ev" + shows + "can_occur ev' c" +proof (cases ev') + case (Snapshot p) + then have "~ has_snapshotted c' p" using assms(3) can_occur_def by simp + then have "~ has_snapshotted c p" using assms(1) snapshot_state_unchanged by force + then show ?thesis using can_occur_def Snapshot by simp +next + case (RecvMarker i p q) + then show ?thesis using assms(4) by auto +next + case (Trans p s s') + then show ?thesis + using assms(1) assms(2) can_occur_def no_state_change_if_no_event assms(3) by auto +next + case (Send p q s s' m) + then show ?thesis + using assms(1) assms(2) can_occur_def no_state_change_if_no_event assms(3) by auto +next + case (Recv i p q s s' m) + have "msgs c' i \ Nil" using Recv can_occur_def assms by auto + moreover have "hd (msgs c' i) = Msg m \ length (msgs c' i) > 0" + proof - + from Recv have "length (msgs c' i) > 0" using assms(3) can_occur_def by auto + then obtain m' xs where mcqp: "msgs c' i = m' # xs" + by (metis list.size(3) nat_less_le neq_Nil_conv) + then have "Msg m = m'" + proof (cases m', auto) + case Marker + then have "msgs c' i = Marker # xs" by (simp add:mcqp) + then have "~ can_occur ev' c'" using Recv can_occur_def by simp + then show False using assms(3) by simp + next + case (Msg msg) + then have "msgs c' i = Msg msg # xs" by (simp add: mcqp) + then show "m = msg" using Recv can_occur_def assms(3) by simp + qed + then show ?thesis by (simp add: mcqp) + qed + moreover have "msgs c i \ Nil \ hd (msgs c' i) = hd (msgs c i)" + proof (cases ev) + case (Snapshot p') + then have "p' \ p" using assms Recv by simp + have chan: "channel i = Some (q, p)" + by (metis Recv assms(3) distributed_system.can_occur_Recv distributed_system_axioms) + with Snapshot assms have "length (msgs c i) > 0 \ hd (msgs c i) = hd (msgs c' i)" + proof (cases "q = p'") + case True + then have "msgs c' i = msgs c i @ [Marker]" using Snapshot chan assms by simp + then show ?thesis + by (metis append_self_conv2 calculation(2) hd_append2 length_greater_0_conv list.sel(1) message.simps(3)) + next + case False + then have "msgs c' i = msgs c i" using Snapshot chan assms by simp + then show ?thesis using calculation by simp + qed + then show ?thesis by simp + next + case (RecvMarker i' p' q') + then have "i' \ i" + using Recv assms(1) assms(2) assms(3) can_occur_def by force + then show ?thesis + proof (cases "has_snapshotted c p'") + case True + then have "msgs c i = msgs c' i" using `i' \ i` RecvMarker assms by simp + then show ?thesis using calculation by simp + next + case no_snap: False + then have chan: "channel i = Some (q, p)" + by (metis Recv assms(3) distributed_system.can_occur_Recv distributed_system_axioms) + then show ?thesis + proof (cases "q = p'") + case True + then have "msgs c' i = msgs c i @ [Marker]" + using no_snap RecvMarker \i' \ i\ assms(1) chan by auto + then show ?thesis + by (metis append_self_conv2 calculation(2) hd_append2 list.sel(1) message.simps(3)) + next + case False + then have "msgs c' i = msgs c i" using RecvMarker no_snap False chan assms `i' \ i` by simp + then show ?thesis using calculation by simp + qed + qed + next + case (Trans p' s'' s''') + then show ?thesis using assms(1) `msgs c' i \ Nil` by auto + next + case (Send i' p' q' s'' s''' m'') + have "p' \ p" + using Recv Send assms(2) by auto + then show ?thesis + using Recv Send assms(1) assms(5) calculation(1) by auto + next + case (Recv i' p' q' s'' s''' m'') + then have "i' \ i" using assms `ev' = Recv i p q s s' m` + by (metis distributed_system.can_occur_Recv distributed_system_axioms event.sel(3) next_recv option.inject prod.inject) + have "msgs c i = msgs c' i" using msgs_unchanged_for_other_is Recv \i' \ i\ assms(1) by auto + then show ?thesis using `msgs c' i \ Nil` by simp + qed + moreover have "states c p = states c' p" using no_state_change_if_no_event assms Recv by simp + ultimately show ?thesis + using Recv assms(3) can_occur_def list.case_eq_if by fastforce +qed + +lemma nonregular_event_can_go_back_if_in_distinct_processes: + assumes + "c \ ev \ c'" and + "regular_event ev" and + "~ regular_event ev'" and + "can_occur ev' c'" and + "occurs_on ev \ occurs_on ev'" + shows + "can_occur ev' c" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + have "isTrans ev \ isSend ev \ isRecv ev" using assms by simp + moreover have "isSnapshot ev' \ isRecvMarker ev'" using assms nonregular_event by auto + ultimately show ?thesis + proof (elim disjE, goal_cases) + case 1 + then show ?case + using assms(1) assms(4) assms(5) event_can_go_back_if_no_sender by blast + next + case 2 + then obtain s s' where Trans: "ev = Trans ?p s s'" + by (metis event.collapse(1)) + obtain i r where RecvMarker: "ev' = RecvMarker i ?q r" + using 2 by (metis event.collapse(5)) + have "msgs c i = msgs c' i" + using "2"(1) assms(1) assms(2) no_msg_change_if_no_event by blast + moreover have "can_occur ev' c'" using assms by simp + ultimately show ?thesis using can_occur_def RecvMarker + by (metis (mono_tags, lifting) "2"(2) event.case_eq_if event.distinct_disc(13) event.distinct_disc(17) event.distinct_disc(19) event.distinct_disc(7) event.sel(10)) + next + case 3 + then have "ev' = Snapshot ?q" + by (metis event.collapse(4)) + have "~ has_snapshotted c' ?q" + by (metis (mono_tags, lifting) "3"(1) assms(4) can_occur_def event.case_eq_if event.distinct_disc(11) event.distinct_disc(16) event.distinct_disc(6)) + then have "~ has_snapshotted c ?q" + using assms(1) assms(2) regular_event_preserves_process_snapshots by auto + then show ?case unfolding can_occur_def using `ev' = Snapshot ?q` + by (metis (mono_tags, lifting) event.simps(29)) + next + case 4 + then have "ev' = Snapshot ?q" + by (metis event.collapse(4)) + have "~ has_snapshotted c' ?q" + by (metis (mono_tags, lifting) \ev' = Snapshot (occurs_on ev')\ assms(4) can_occur_def event.simps(29)) + then have "~ has_snapshotted c ?q" + using assms(1) assms(2) regular_event_preserves_process_snapshots by auto + then show ?case unfolding can_occur_def + by (metis (mono_tags, lifting) \ev' = Snapshot (occurs_on ev')\ event.simps(29)) + next + case 5 + then obtain i s u u' m where "ev = Send i ?p s u u' m" + by (metis event.collapse(2)) + from 5 obtain i' r where "ev' = RecvMarker i' ?q r" + by (metis event.collapse(5)) + then have pre: "hd (msgs c' i') = Marker \ length (msgs c' i') > 0" + by (metis (mono_tags, lifting) assms(4) can_occur_def event.simps(30)) + have "hd (msgs c i') = Marker \ length (msgs c i') > 0" + proof (cases "i' = i") + case False + then have "msgs c i' = msgs c' i'" + by (metis \ev = Send i (occurs_on ev) s u u' m\ assms(1) assms(2) event.sel(8) msgs_unchanged_for_other_is) + then show ?thesis using pre by auto + next + case True + then have "msgs c' i' = msgs c i' @ [Msg m]" + by (metis \ev = Send i (occurs_on ev) s u u' m\ assms(1) next_send) + then have "length (msgs c' i') > 1" + using pre by fastforce + then have "length (msgs c i') > 0" + by (simp add: \msgs c' i' = msgs c i' @ [Msg m]\) + then show ?thesis + using \msgs c' i' = msgs c i' @ [Msg m]\ pre by auto + qed + then show ?case unfolding can_occur_def using `ev' = RecvMarker i' ?q r` + by (metis (mono_tags, lifting) assms(4) can_occur_def event.simps(30)) + next + case 6 + then obtain i s u u' m where "ev = Recv i ?p s u u' m" + by (metis event.collapse(3)) + from 6 obtain i' r where "ev' = RecvMarker i' ?q r" + by (metis event.collapse(5)) + then have "i' \ i" + proof - + have "?p \ ?q" using assms by simp + moreover have "channel i = Some (s, ?p)" + by (metis \ev = Recv i (occurs_on ev) s u u' m\ assms(1) distributed_system.can_occur_Recv distributed_system_axioms happen_implies_can_occur) + moreover have "channel i' = Some (r, ?q)" + by (metis (mono_tags, lifting) \ev' = RecvMarker i' (occurs_on ev') r\ assms(4) can_occur_def event.case_eq_if event.disc(5,10,15,20) event.sel(5,10,13)) + ultimately show ?thesis by auto + qed + then show ?case + by (metis (mono_tags, lifting) "6"(1) \ev = Recv i (occurs_on ev) s u u' m\ \ev' = RecvMarker i' (occurs_on ev') r\ assms(1) assms(4) can_occur_def event.case_eq_if event.distinct_disc(13) event.distinct_disc(17) event.distinct_disc(7) event.sel(10) next_recv) + qed +qed + +lemma same_state_implies_same_result_state: + assumes + "states c p = states d p" + "c \ ev \ c'" and + "d \ ev \ d'" + shows + "states d' p = states c' p" +proof (cases "occurs_on ev = p") + case False + then show ?thesis + by (metis assms(1-3) distributed_system.no_state_change_if_no_event distributed_system_axioms) +next + case True + then show ?thesis + using assms by (cases ev, auto) +qed + +lemma same_snapshot_state_implies_same_result_snapshot_state: + assumes + "ps c p = ps d p" and + "states c p = states d p" and + "c \ ev \ c'" and + "d \ ev \ d'" + shows + "ps d' p = ps c' p" +proof (cases "occurs_on ev = p") + case False + then show ?thesis + using assms no_state_change_if_no_event by auto +next + case True + then show ?thesis + proof (cases ev) + case (Snapshot q) + then have "p = q" using True by auto + then show ?thesis + using Snapshot assms(2) assms(3) assms(4) by auto + next + case (RecvMarker i q r) + then have "p = q" using True by auto + then show ?thesis + proof - + have f1: "\c ca. \ c \ ev \ ca \ ps c p = None \ ps c p = ps ca p" + using RecvMarker \p = q\ by force + have "\c ca. ps c p \ None \ \ c \ ev \ ca \ ps ca p = Some (states c p)" + using RecvMarker \p = q\ by force + then show ?thesis + using f1 by (metis (no_types) assms(1) assms(2) assms(3) assms(4)) + qed + next + case (Trans q s s') + then have "p = q" + using True by auto + then show ?thesis + using Trans assms(1) assms(3) assms(4) by auto + next + case (Send i q r u u' m) + then have "p = q" using True by auto + then show ?thesis + using Send assms(1) assms(3) assms(4) by auto + next + case (Recv i q r u u' m) + then have "p = q" using True by auto + then show ?thesis + using Recv assms(1) assms(3) assms(4) by auto + qed +qed + +lemma same_messages_imply_same_resulting_messages: + assumes + "msgs c i = msgs d i" + "c \ ev \ c'" and + "d \ ev \ d'" and + "regular_event ev" + shows + "msgs c' i = msgs d' i" +proof - + have "isTrans ev \ isSend ev \ isRecv ev" using assms + by simp + then show ?thesis + proof (elim disjE) + assume "isTrans ev" + then show ?thesis + by (metis assms(1) assms(2) assms(3) isTrans_def next_trans) + next + assume "isSend ev" + then obtain i' r s u u' m where "ev = Send i' r s u u' m" + by (metis event.collapse(2)) + with assms show ?thesis by (cases "i = i'", auto) + next + assume "isRecv ev" + then obtain i' r s u u' m where Recv: "ev = Recv i' r s u u' m" + by (metis event.collapse(3)) + with assms show ?thesis by (cases "i = i'", auto) + qed +qed + +lemma Trans_msg: + assumes + "c \ ev \ c'" and + "isTrans ev" + shows + "msgs c i = msgs c' i" + using assms(1) assms(2) no_msg_change_if_no_event regular_event by blast + +lemma new_msg_in_set_implies_occurrence: + assumes + "c \ ev \ c'" and + "m \ set (msgs c i)" and + "m \ set (msgs c' i)" and + "channel i = Some (p, q)" + shows + "occurs_on ev = p" (is ?P) +proof (rule ccontr) + assume "~ ?P" + have "set (msgs c' i) \ set (msgs c i)" + proof (cases ev) + case (Snapshot r) + then have "msgs c' i = msgs c i" using `~ ?P` assms by simp + then show ?thesis by auto + next + case (RecvMarker i' r s) + then show ?thesis + proof (cases "has_snapshotted c r") + case True + then show ?thesis + proof (cases "i' = i") + case True + then have "Marker # msgs c' i = msgs c i" using RecvMarker True assms by simp + then show ?thesis + by (metis set_subset_Cons) + next + case False + then show ?thesis using RecvMarker True assms by simp + qed + next + case no_snap: False + have chan: "channel i' = Some (s, r)" + using RecvMarker assms(1) can_occur_def by auto + then show ?thesis + proof (cases "i' = i") + case True + then have "Marker # msgs c' i = msgs c i" using RecvMarker assms by simp + then show ?thesis by (metis set_subset_Cons) + next + case False + then have "msgs c' i = msgs c i" using `~ ?P` RecvMarker assms no_snap by simp + then show ?thesis by simp + qed + qed + next + case (Trans r u u') + then show ?thesis using assms `~ ?P` by simp + next + case (Send i' r s u u' m') + then have "i' \ i" using `~ ?P` can_occur_def assms by auto + then have "msgs c i = msgs c' i" using `~ ?P` assms Send by simp + then show ?thesis by simp + next + case (Recv i' r s u u' m') + then show ?thesis + by (metis (no_types, lifting) assms(1) eq_iff local.next.simps(5) set_subset_Cons) + qed + moreover have "~ set (msgs c' i) \ set (msgs c i)" using assms by blast + ultimately show False by simp +qed + +lemma new_Marker_in_set_implies_nonregular_occurence: + assumes + "c \ ev \ c'" and + "Marker \ set (msgs c i)" and + "Marker \ set (msgs c' i)" and + "channel i = Some (p, q)" + shows + "~ regular_event ev" (is ?P) +proof (rule ccontr) + have "occurs_on ev = p" + using assms new_msg_in_set_implies_occurrence by blast + assume "~ ?P" + then have "isTrans ev \ isSend ev \ isRecv ev" by simp + then have "Marker \ set (msgs c' i)" + proof (elim disjE, goal_cases) + case 1 + then obtain r u u' where "ev = Trans r u u'" + by (metis event.collapse(1)) + then show ?thesis + using assms(1) assms(2) by auto + next + case 2 + then obtain i' r q u u' m where "ev = Send i' r q u u' m" + by (metis event.collapse(2)) + then show ?thesis + by (metis (no_types, lifting) Un_iff assms(1) assms(2) empty_iff empty_set insert_iff list.set(2) message.distinct(1) next_send set_append) + next + case 3 + then obtain i' r q u u' m where "ev = Recv i' r q u u' m" + by (metis event.collapse(3)) + then show ?thesis + by (metis assms(1) assms(2) list.set_intros(2) next_recv) + qed + then show False using assms by simp +qed + +lemma RecvMarker_implies_Marker_in_set: + assumes + "c \ ev \ c'" and + "ev = RecvMarker cid p q" + shows + "Marker \ set (msgs c cid)" + by (metis (mono_tags, lifting) assms(1) assms(2) can_occur_def distributed_system.happen_implies_can_occur distributed_system_axioms event.simps(30) list.set_sel(1) list.size(3) nat_less_le) + +lemma RecvMarker_given_channel: + assumes + "isRecvMarker ev" and + "getId ev = cid" and + "channel cid = Some (p, q)" and + "can_occur ev c" + shows + "ev = RecvMarker cid q p" + by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) assms(4) can_occur_def event.case_eq_if event.collapse(5) event.distinct_disc(8,14,18,20) option.inject prod.inject) + +lemma Recv_given_channel: + assumes + "isRecv ev" and + "getId ev = cid" and + "channel cid = Some (p, q)" and + "can_occur ev c" + shows + "\s s' m. ev = Recv cid q p s s' m" + by (metis assms(1) assms(2) assms(3) assms(4) distributed_system.can_occur_Recv distributed_system_axioms event.collapse(3) option.inject prod.inject) + +lemma same_cs_if_not_recv: + assumes + "c \ ev \ c'" and + "~ isRecv ev" + shows + "fst (cs c cid) = fst (cs c' cid)" +proof (cases "channel cid = None") + case True + then show ?thesis + using assms(1) no_cs_change_if_no_channel by auto +next + case False + then obtain p q where chan: "channel cid = Some (p, q)" by auto + then show ?thesis + proof (cases ev) + case (Snapshot r) + with Snapshot assms chan show ?thesis by (cases "r = q", auto) + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "has_snapshotted c r") + case True + with assms RecvMarker chan show ?thesis by (cases "cid' = cid", auto) + next + case no_snap: False + then show ?thesis + proof (cases "cid' = cid") + case True + then show ?thesis using RecvMarker assms chan by auto + next + case False + with assms RecvMarker chan no_snap show ?thesis by (cases "r = q", auto) + qed + qed + next + case (Trans r u u') + then show ?thesis using assms by auto + next + case (Send r s u u') + then show ?thesis using assms by auto + qed (metis assms(2) isRecv_def) +qed + +lemma done_only_from_recv_marker: + assumes + "c \ ev \ c'" and + "channel cid = Some (p, q)" and + "snd (cs c cid) \ Done" and + "snd (cs c' cid) = Done" + shows + "ev = RecvMarker cid q p" +proof (rule ccontr) + assume "~ ev = RecvMarker cid q p" + then show False + proof (cases "isRecvMarker ev") + case True + then obtain cid' s r where RecvMarker: "ev = RecvMarker cid' s r" by (meson isRecvMarker_def) + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then show False + using \ev = RecvMarker cid' s r\ \ev \ RecvMarker cid q p\ assms(1) assms(2) can_occur_def by auto + qed + then have "snd (cs c' cid) \ Done" + proof (cases "has_snapshotted c s") + case True + then show ?thesis using RecvMarker assms `cid \ cid'` by simp + next + case False + with RecvMarker assms `cid \ cid'` show ?thesis by (cases "s = q", auto) + qed + then show False using assms by auto + next + case False + then have "isSnapshot ev \ isTrans ev \ isSend ev \ isRecv ev" + using event.exhaust_disc by blast + then have "snd (cs c' cid) \ Done" + proof (elim disjE, goal_cases) + case 1 + then obtain r where Snapshot: "ev = Snapshot r" + by (meson isSnapshot_def) + with assms show ?thesis by (cases "q = r", auto) + next + case 2 + then obtain r u u' where "ev = Trans r u u'" + by (meson isTrans_def) + then show ?case using assms by auto + next + case 3 + then obtain cid' r s u u' m where "ev = Send cid' r s u u' m" + by (meson isSend_def) + then show ?thesis using assms by auto + next + case 4 + then obtain cid' r s u u' m where Recv: "ev = Recv cid' r s u u' m" + by (meson isRecv_def) + show ?thesis + using Recv assms proof (cases "cid = cid'") + case True + then have "snd (cs c cid) = NotStarted \ snd (cs c cid) = Recording" + using assms(3) recording_state.exhaust by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then have "snd (cs c' cid') = NotStarted" + using True Recv assms(1) by auto + then show ?case using True by auto + next + case 2 + then have "snd (cs c' cid') = Recording" + using True Recv assms(1) by auto + then show ?case using True by auto + qed + qed auto + qed + then show False using assms by auto + qed +qed + +lemma cs_not_not_started_stable: + assumes + "c \ ev \ c'" and + "snd (cs c cid) \ NotStarted" and + "channel cid = Some (p, q)" + shows + "snd (cs c' cid) \ NotStarted" +using assms proof (cases ev) + case (Snapshot r) + then show ?thesis + by (metis assms(1) assms(2) next_snapshot recording_state.simps(2) sndI) +next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "has_snapshotted c r") + case True + with RecvMarker assms show ?thesis by (cases "cid = cid'", auto) + next + case no_snap: False + then show ?thesis + proof (cases "cid = cid'") + case True + then show ?thesis using RecvMarker assms by auto + next + case False + with RecvMarker assms no_snap show ?thesis by (cases "s = p", auto) + qed + qed +next + case (Recv cid' r s u u' m) + then have "snd (cs c cid) = Recording \ snd (cs c cid) = Done" + using assms(2) recording_state.exhaust by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then show ?thesis + by (metis (no_types, lifting) Recv assms(1) eq_snd_iff next_recv recording_state.distinct(1)) + next + case 2 + with Recv assms show ?thesis by (cases "cid = cid'", auto) + qed +qed auto + +lemma fst_cs_changed_by_recv_recording: + assumes + step: "c \ ev \ c'" and + "fst (cs c cid) \ fst (cs c' cid)" and + "channel cid = Some (p, q)" + shows + "snd (cs c cid) = Recording \ (\p q u u' m. ev = Recv cid q p u u' m)" +proof - + have oc_on: "occurs_on ev = q" + proof - + obtain nn :: "('p, 's, 'm) event \ nat" and aa :: "('p, 's, 'm) event \ 'p" and aaa :: "('p, 's, 'm) event \ 'p" and bb :: "('p, 's, 'm) event \ 's" and bba :: "('p, 's, 'm) event \ 's" and cc :: "('p, 's, 'm) event \ 'm" where + f1: "\e. (\ isRecv e \ e = Recv (nn e) (aa e) (aaa e) (bb e) (bba e) (cc e)) \ (isRecv e \ (\n a aa b ba c. e \ Recv n a aa b ba c))" + using isRecv_def by moura + then have f2: "c \ Recv (nn ev) (aa ev) (aaa ev) (bb ev) (bba ev) (cc ev) \ c'" + by (metis (no_types) assms(2) local.step same_cs_if_not_recv) + have f3: "\x0 x1 x7 x8. (x0 \ x7 \ cs (x8::('p, 's, 'm) configuration) x0 = cs (x1::('p, 's, _) configuration) x0) = (x0 = x7 \ cs x8 x0 = cs x1 x0)" + by auto + have f4: "\x0 x1 x7 x8. (x7 \ x0 \ msgs (x1::('p, 's, 'm) configuration) x0 = msgs (x8::('p, 's, _) configuration) x0) = (x7 = x0 \ msgs x1 x0 = msgs x8 x0)" + by auto + have "\x0 x1 x6 x8. (x0 \ x6 \ states (x1::('p, 's, 'm) configuration) x0 = states (x8::(_, _, 'm) configuration) x0) = (x0 = x6 \ states x1 x0 = states x8 x0)" + by fastforce + then have "can_occur (Recv (nn ev) (aa ev) (aaa ev) (bb ev) (bba ev) (cc ev)) c \ states c (aa ev) = bb ev \ states c' (aa ev) = bba ev \ (\a. a = aa ev \ states c' a = states c a) \ msgs c (nn ev) = Msg (cc ev) # msgs c' (nn ev) \ (\n. nn ev = n \ msgs c' n = msgs c n) \ (\a. ps c a = ps c' a) \ (\n. n = nn ev \ cs c n = cs c' n) \ (if snd (cs c (nn ev)) = Recording then cs c' (nn ev) = (fst (cs c (nn ev)) @ [cc ev], Recording) else cs c (nn ev) = cs c' (nn ev))" + using f4 f3 f2 by force + then show ?thesis + using f1 by (metis (no_types) Pair_inject assms(2) assms(3) can_occur_Recv event.sel(3) local.step option.sel same_cs_if_not_recv) +qed + have "isRecv ev" (is ?P) + proof (rule ccontr) + assume "~ ?P" + then have "fst (cs c cid) = fst (cs c' cid)" by (metis local.step same_cs_if_not_recv) + then show False using assms by simp + qed + then obtain cid' r s u u' m where Recv: "ev = Recv cid' r s u u' m" by (meson isRecv_def) + have "cid = cid'" + proof (rule ccontr) + assume "~ cid = cid'" + then have "fst (cs c cid) = fst (cs c' cid)" using Recv step by auto + then show False using assms by simp + qed + moreover have "snd (cs c cid) = Recording" + proof (rule ccontr) + assume "~ snd (cs c cid) = Recording" + then have "fst (cs c cid) = fst (cs c' cid)" using Recv step `cid = cid'` by auto + then show False using assms by simp + qed + ultimately show ?thesis using Recv by simp +qed + +lemma no_marker_and_snapshotted_implies_no_more_markers: + assumes + "c \ ev \ c'" and + "has_snapshotted c p" and + "Marker \ set (msgs c cid)" and + "channel cid = Some (p, q)" + shows + "Marker \ set (msgs c' cid)" +proof (cases ev) + case (Snapshot r) + then have "r \ p" + using assms(1) assms(2) can_occur_def by auto + then have "msgs c cid = msgs c' cid" using assms Snapshot by simp + then show ?thesis using assms by simp +next + case (RecvMarker cid' r s) + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + moreover have "can_occur ev c" using happen_implies_can_occur assms by blast + ultimately have "Marker : set (msgs c cid)" using can_occur_def RecvMarker + by (metis (mono_tags, lifting) assms(1) event.simps(30) hd_in_set list.size(3) recv_marker_other_channels_not_shrinking zero_order(1)) + then show False using assms by simp + qed + then have "msgs c cid = msgs c' cid" + proof (cases "r = p") + case True + then show ?thesis + using RecvMarker \cid \ cid'\ assms(1) assms(2) msgs_unchanged_if_snapshotted_RecvMarker_for_other_is by blast + next + case False + with RecvMarker `cid \ cid'` step assms show ?thesis by (cases "has_snapshotted c r", auto) + qed + then show ?thesis using assms by simp +next + case (Trans r u u') + then show ?thesis using assms by auto +next + case (Send cid' r s u u' m) + with assms Send show ?thesis by (cases "cid = cid'", auto) +next + case (Recv cid' r s u u' m) + with assms Recv show ?thesis by (cases "cid = cid'", auto) +qed + +lemma same_messages_if_no_occurrence: + assumes + "c \ ev \ c'" and + "~ occurs_on ev = p" and + "~ occurs_on ev = q" and + "channel cid = Some (p, q)" + shows + "msgs c cid = msgs c' cid \ cs c cid = cs c' cid" +proof (cases ev) + case (Snapshot r) + then show ?thesis using assms by auto +next + case (RecvMarker cid' r s) + have "cid \ cid'" + by (metis RecvMarker_given_channel assms(1) assms(3) assms(4) RecvMarker event.sel(5,10) happen_implies_can_occur isRecvMarker_def) + have "\a. channel cid = Some (r, q)" + using assms(2) assms(4) RecvMarker by auto + with RecvMarker assms `cid \ cid'` show ?thesis by (cases "has_snapshotted c r", auto) +next + case (Trans r u u') + then show ?thesis using assms by auto +next + case (Send cid' r s u u' m) + then have "cid \ cid'" + by (metis (mono_tags, lifting) Pair_inject assms(1) assms(2) assms(4) can_occur_def event.sel(2) event.simps(27) happen_implies_can_occur option.inject) + then show ?thesis using assms Send by simp +next + case (Recv cid' r s u u' m) + then have "cid \ cid'" + by (metis assms(1) assms(3) assms(4) distributed_system.can_occur_Recv distributed_system.happen_implies_can_occur distributed_system_axioms event.sel(3) option.inject prod.inject) + then show ?thesis using assms Recv by simp +qed + +end (* locale distributed_system *) + +end (* theory Distributed_System *) diff --git a/thys/Chandy_Lamport/Example.thy b/thys/Chandy_Lamport/Example.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Example.thy @@ -0,0 +1,274 @@ +section \Example\ + +text \We provide an example in order to prove that our locale is non-vacuous. +This example corresponds to the computation and associated snapshot described +in Section 4 of~\cite{chandy}.\ + +theory Example + imports + Snapshot + +begin + +datatype PType = P | Q +datatype MType = M | M' +datatype SType = S_Wait | S_Send | T_Wait | T_Send + +fun trans :: "PType \ SType \ SType \ bool" where + "trans p s s' = False" + +fun send :: "channel_id \ PType \ PType \ SType + \ SType \ MType \ bool" where + "send c p q s s' m = ((c = 0 \ p = P \ q = Q + \ s = S_Send \ s' = S_Wait \ m = M) + \ (c = 1 \ p = Q \ q = P + \ s = T_Send \ s' = T_Wait \ m = M'))" + +fun recv :: "channel_id \ PType \ PType \ SType + \ SType \ MType \ bool" where + "recv c p q s s' m = ((c = 1 \ p = P \ q = Q + \ s = S_Wait \ s' = S_Send \ m = M') + \ (c = 0 \ p = Q \ q = P + \ s = T_Wait \ s' = T_Send \ m = M))" + +fun chan :: "nat \ (PType * PType) option" where + "chan n = (if n = 0 then Some (P, Q) + else if n = 1 then Some (Q, P) + else None)" + +abbreviation init :: "(PType, SType, MType) configuration" where + "init \ \ + states = (%p. if p = P then S_Send else T_Send), + msgs = (%d. []), + process_snapshot = (%p. None), + channel_snapshot = (%d. ([], NotStarted)) + \" + +abbreviation t0 where "t0 \ Snapshot P" + +abbreviation s1 :: "(PType, SType, MType) configuration" where + "s1 \ \ + states = (%p. if p = P then S_Send else T_Send), + msgs = (%d. if d = 0 then [Marker] else []), + process_snapshot = (%p. if p = P then Some S_Send else None), + channel_snapshot = (%d. if d = 1 then ([], Recording) else ([], NotStarted)) + \" + +abbreviation t1 where "t1 \ Send 0 P Q S_Send S_Wait M" + +abbreviation s2 :: "(PType, SType, MType) configuration" where + "s2 \ \ + states = (%p. if p = P then S_Wait else T_Send), + msgs = (%d. if d = 0 then [Marker, Msg M] else []), + process_snapshot = (%p. if p = P then Some S_Send else None), + channel_snapshot = (%d. if d = 1 then ([], Recording) else ([], NotStarted)) + \" + +abbreviation t2 where "t2 \ Send 1 Q P T_Send T_Wait M'" + +abbreviation s3 :: "(PType, SType, MType) configuration" where + "s3 \ \ + states = (%p. if p = P then S_Wait else T_Wait), + msgs = (%d. if d = 0 then [Marker, Msg M] else if d = 1 then [Msg M'] else []), + process_snapshot = (%p. if p = P then Some S_Send else None), + channel_snapshot = (%d. if d = 1 then ([], Recording) else ([], NotStarted)) + \" + +abbreviation t3 where "t3 \ Snapshot Q" + +abbreviation s4 :: "(PType, SType, MType) configuration" where + "s4 \ \ + states = (%p. if p = P then S_Wait else T_Wait), + msgs = (%d. if d = 0 then [Marker, Msg M] else if d = 1 then [Msg M', Marker] else []), + process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait), + channel_snapshot = (%d. if d = 1 then ([], Recording) else if d = 0 then ([], Recording) else ([], NotStarted)) + \" + +abbreviation t4 where "t4 \ RecvMarker 0 Q P" + +abbreviation s5 :: "(PType, SType, MType) configuration" where + "s5 \ \ + states = (%p. if p = P then S_Wait else T_Wait), + msgs = (%d. if d = 0 then [Msg M] else if d = 1 then [Msg M', Marker] else []), + process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait), + channel_snapshot = (%d. if d = 0 then ([], Done) else if d = 1 then ([], Recording) else ([], NotStarted)) + \" + +abbreviation t5 where "t5 \ Recv 1 P Q S_Wait S_Send M'" + +abbreviation s6 :: "(PType, SType, MType) configuration" where + "s6 \ \ + states = (%p. if p = P then S_Send else T_Wait), + msgs = (%d. if d = 0 then [Msg M] else if d = 1 then [Marker] else []), + process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait), + channel_snapshot = (%d. if d = 0 then ([], Done) else if d = 1 then ([M'], Recording) else ([], NotStarted)) + \" + +abbreviation t6 where "t6 \ RecvMarker 1 P Q" + +abbreviation s7 :: "(PType, SType, MType) configuration" where + "s7 \ \ + states = (%p. if p = P then S_Send else T_Wait), + msgs = (%d. if d = 0 then [Msg M] else if d = 1 then [] else []), + process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait), + channel_snapshot = (%d. if d = 0 then ([], Done) else if d = 1 then ([M'], Done) else ([], NotStarted)) + \" + +lemma s7_no_marker: + shows + "\cid. Marker \ set (msgs s7 cid)" + by simp + +interpretation computation chan trans send recv init s7 +proof + have "distributed_system chan" + proof + show "\i. \p. chan i = Some (p, p)" by simp + qed + show "\p q. p \ q \ (\p q. \i. chan i = Some (p, q))\<^sup>+\<^sup>+ p q" + proof ((rule allI)+, rule impI) + fix p q :: PType assume "p \ q" + then have "(p = P \ q = Q) \ (p = Q \ q = P)" + using PType.exhaust by auto + then have "\i. chan i = Some (p, q)" by (elim disjE) auto + then show "(\p q. \i. chan i = Some (p, q))\<^sup>+\<^sup>+ p q" by blast + qed + show "finite {i. \p q. chan i = Some (p, q)}" + proof - + have "{i. \p q. chan i = Some (p, q)} = {0,1}" by auto + then show ?thesis by simp + qed + show "1 < card (UNIV :: PType set)" + proof - + have "(UNIV :: PType set) = {P, Q}" + using PType.exhaust by blast + then have "card (UNIV :: PType set) = 2" + by (metis One_nat_def PType.distinct(1) Suc_1 card.insert card_empty finite.emptyI finite.insertI insert_absorb insert_not_empty singletonD) + then show ?thesis by auto + qed + show "finite (UNIV :: PType set)" + proof - + have "(UNIV :: PType set) = {P, Q}" + using PType.exhaust by blast + then show ?thesis + by (metis finite.emptyI finite.insertI) + qed + show "\i. \p. chan i = Some (p, p)" by simp + show "\i. (\p q. chan i = Some (p, q)) \ Marker \ set (msgs init i)" by auto + show "\i. chan i = None \ msgs init i = []" by auto + show "\p. \ ps init p \ None" by auto + show "\i. cs init i = ([], NotStarted)" by auto + show "\t. distributed_system.trace chan Example.trans send recv init t s7" + proof - + let ?t = "[t0, t1, t2, t3, t4, t5, t6]" + have "distributed_system.next chan trans send recv init t0 s1" + proof - + have "distributed_system.can_occur chan trans send recv t0 init" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + then show ?thesis + by (simp add: \distributed_system chan\ distributed_system.next_snapshot) + qed + moreover have "distributed_system.next chan trans send recv s1 t1 s2" + proof - + have "distributed_system.can_occur chan trans send recv t1 s1" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + then show ?thesis + by (simp add: \distributed_system chan\ distributed_system.next_send) + qed + moreover have "distributed_system.next chan trans send recv s2 t2 s3" + proof - + have "distributed_system.can_occur chan trans send recv t2 s2" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + moreover have "\r. r \ P \ r = Q" using PType.exhaust by auto + ultimately show ?thesis by (simp add: `distributed_system chan` distributed_system.next_send) + qed + moreover have "distributed_system.next chan trans send recv s3 t3 s4" + proof - + have "distributed_system.can_occur chan trans send recv t3 s3" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + moreover have "\p'. p' \ P \ p' = Q" using PType.exhaust by auto + ultimately show ?thesis by (simp add: `distributed_system chan` distributed_system.next_snapshot) + qed + moreover have "distributed_system.next chan trans send recv s4 t4 s5" + proof - + have "distributed_system.can_occur chan trans send recv t4 s4" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + then show ?thesis + by (simp add: `distributed_system chan` distributed_system.next_def) + qed + moreover have "distributed_system.next chan trans send recv s5 t5 s6" + proof - + have "distributed_system.can_occur chan trans send recv t5 s5" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + then show ?thesis + by (simp add: `distributed_system chan` distributed_system.next_def) + qed + moreover have "distributed_system.next chan trans send recv s6 t6 s7" + proof - + have "distributed_system.can_occur chan trans send recv t6 s6" + using \distributed_system chan\ distributed_system.can_occur_def by fastforce + then show ?thesis + by (simp add: `distributed_system chan` distributed_system.next_def) + qed + ultimately have "distributed_system.trace chan trans send recv init ?t s7" + by (meson \distributed_system chan\ distributed_system.trace.simps) + then show ?thesis by blast + qed + show "\t i cid. distributed_system.trace chan Example.trans send recv init t s7 \ + Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t i) cid) \ + (\j\i. Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t j) cid))" + proof ((rule allI)+, (rule impI)+) + fix t i cid + assume asm: "distributed_system.trace chan Example.trans send recv init t s7 \ + Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t i) cid)" + have tr_exists: "distributed_system.trace chan Example.trans send recv init t s7" using asm by blast + have marker_in_channel: "Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t i) cid)" using asm by simp + have s7_is_fin: "s7 = (distributed_system.s chan Example.trans send recv init t (length t))" + by (metis (no_types, lifting) \distributed_system chan\ \distributed_system.trace chan Example.trans send recv init t s7\ distributed_system.exists_trace_for_any_i distributed_system.trace_and_start_determines_end order_refl take_all) + have "i < length t" + proof (rule ccontr) + assume "~ i < length t" + then have "distributed_system.trace chan Example.trans send recv + (distributed_system.s chan Example.trans send recv init t (length t)) + [] + (distributed_system.s chan Example.trans send recv init t i)" + by (metis (no_types, lifting) \distributed_system chan\ distributed_system.exists_trace_for_any_i distributed_system.trace.simps distributed_system.trace_and_start_determines_end not_less s7_is_fin take_all tr_exists) + then have "Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t i) cid)" + proof - + have "distributed_system.s chan Example.trans send recv init t i = s7" + using \distributed_system chan\ \distributed_system.trace chan Example.trans send recv (distributed_system.s chan Example.trans send recv init t (length t)) [] (distributed_system.s chan Example.trans send recv init t i)\ distributed_system.trace.simps s7_is_fin by fastforce + then show ?thesis using s7_no_marker by simp + qed + then show False using marker_in_channel by simp + qed + then show "(\j\i. Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t j) cid))" + proof - + have "distributed_system.trace chan Example.trans send recv + (distributed_system.s chan Example.trans send recv init t i) + (take ((length t) - i) (drop i t)) + (distributed_system.s chan Example.trans send recv init t (length t))" + using \distributed_system chan\ \i < length t\ distributed_system.exists_trace_for_any_i_j less_imp_le_nat tr_exists by blast + then have "Marker \ set (msgs (distributed_system.s chan Example.trans send recv init t (length t)) cid)" + proof - + have "distributed_system.s chan Example.trans send recv init t (length t) = s7" + by (simp add: s7_is_fin) + then show ?thesis using s7_no_marker by simp + qed + then show ?thesis + using \i < length t\ less_imp_le_nat by blast + qed + qed + show "\t p. distributed_system.trace chan Example.trans send recv init t s7 \ + (\i. ps (distributed_system.s chan Example.trans send recv init t i) p \ None \ i \ length t)" + proof ((rule allI)+, rule impI) + fix t p + assume "distributed_system.trace chan Example.trans send recv init t s7" + have s7_is_fin: "s7 = (distributed_system.s chan Example.trans send recv init t (length t))" + by (metis (no_types, lifting) \distributed_system chan\ \distributed_system.trace chan Example.trans send recv init t s7\ distributed_system.exists_trace_for_any_i distributed_system.trace_and_start_determines_end order_refl take_all) + moreover have "has_snapshotted s7 p" by simp + ultimately show "(\i. ps (distributed_system.s chan Example.trans send recv init t i) p \ None \ i \ length t)" + by auto + qed +qed + +end diff --git a/thys/Chandy_Lamport/ROOT b/thys/Chandy_Lamport/ROOT new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/ROOT @@ -0,0 +1,14 @@ +chapter AFP + +session "Chandy_Lamport" (AFP) = + "Ordered_Resolution_Prover" + + options [timeout = 600] + theories + Distributed_System + Trace + Snapshot + Co_Snapshot + Example + document_files + "root.tex" + "root.bib" diff --git a/thys/Chandy_Lamport/Snapshot.thy b/thys/Chandy_Lamport/Snapshot.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Snapshot.thy @@ -0,0 +1,5272 @@ +section \The Chandy--Lamport algorithm\ + +theory Snapshot + imports + "HOL-Library.Sublist" + "HOL-Library.Permutation" + Distributed_System + Trace + Util + Swap + +begin + +subsection \The computation locale\ + +text \We extend the distributed system locale presented +earlier: Now we are given a trace t of the distributed system between +two configurations, the initial and final configuartions of t. Our objective +is to show that the Chandy--Lamport algorithm terminated successfully and +exhibits the same properties as claimed in~\cite{chandy}. In the initial state +no snapshotting must have taken place yet, however the computation itself may +have progressed arbitrarily far already. + +We assume that there exists at least one process, that the +total number of processes in the system is finite, and that there +are only finitely many channels between the processes. The process graph +is strongly connected. Finally there are Chandy and Lamport's core assumptions: +every process snapshots at some time and no marker may remain in a channel forever.\ + +locale computation = distributed_system + + fixes + init final :: "('a, 'b, 'c) configuration" + assumes + finite_channels: + "finite {i. \p q. channel i = Some (p, q)}" and + strongly_connected_raw: + "\p q. (p \ q) \ + (tranclp (\p q. (\i. channel i = Some (p, q)))) p q" and + + at_least_two_processes: + "card (UNIV :: 'a set) > 1" and + finite_processes: + "finite (UNIV :: 'a set)" and + + no_initial_Marker: + "\i. (\p q. channel i = Some (p, q)) + \ Marker \ set (msgs init i)" and + no_msgs_if_no_channel: + "\i. channel i = None \ msgs init i = []" and + no_initial_process_snapshot: + "\p. ~ has_snapshotted init p" and + no_initial_channel_snapshot: + "\i. channel_snapshot init i = ([], NotStarted)" and + + valid: "\t. trace init t final" and + l1: "\t i cid. trace init t final + \ Marker \ set (msgs (s init t i) cid) + \ (\j. j \ i \ Marker \ set (msgs (s init t j) cid))" and + l2: "\t p. trace init t final + \ (\i. has_snapshotted (s init t i) p \ i \ length t)" +begin + +definition has_channel where + "has_channel p q \ (\i. channel i = Some (p, q))" + +lemmas strongly_connected = strongly_connected_raw[folded has_channel_def] + +lemma exists_some_channel: + shows "\i p q. channel i = Some (p, q)" +proof - + obtain p q where "p : (UNIV :: 'a set) \ q : (UNIV :: 'a set) \ p \ q" + by (metis (mono_tags) One_nat_def UNIV_eq_I all_not_in_conv at_least_two_processes card_Suc_Diff1 card_empty finite_processes insert_iff iso_tuple_UNIV_I less_numeral_extra(4) n_not_Suc_n) + then have "(tranclp has_channel) p q" using strongly_connected by simp + then obtain r s where "has_channel r s" + by (meson tranclpD) + then show ?thesis using has_channel_def by auto +qed + +abbreviation S where + "S \ s init" + +lemma no_messages_if_no_channel: + assumes "trace init t final" + shows "channel cid = None \ msgs (s init t i) cid = []" + using no_messages_introduced_if_no_channel[OF assms no_msgs_if_no_channel] by blast + +lemma S_induct [consumes 3, case_names S_init S_step]: + "\ trace init t final; i \ j; j \ length t; + \i. P i i; + \i j. i < j \ j \ length t \ (S t i) \ (t ! i) \ (S t (Suc i)) \ P (Suc i) j \ P i j + \ \ P i j" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by simp +next + case (Suc n) + then have "(S t i) \ (t ! i) \ (S t (Suc i))" using Suc step_Suc by simp + then show ?case using Suc by simp +qed + +lemma exists_index: + assumes + "trace init t final" and + "ev \ set (take (j - i) (drop i t))" + shows + "\k. i \ k \ k < j \ ev = t ! k" +proof - + have "trace (S t i) (take (j - i) (drop i t)) (S t j)" + by (metis assms(1) assms(2) diff_is_0_eq' exists_trace_for_any_i_j list.distinct(1) list.set_cases nat_le_linear take_eq_Nil) + obtain l where "ev = (take (j - i) (drop i t)) ! l" "l < length (take (j - i) (drop i t))" + by (metis assms(2) in_set_conv_nth) + let ?k = "l + i" + have "(take (j - i) (drop i t)) ! l = drop i t ! l" + using \l < length (take (j - i) (drop i t))\ by auto + also have "... = t ! ?k" + by (metis add.commute assms(2) drop_all empty_iff list.set(1) nat_le_linear nth_drop take_Nil) + finally have "ev = t ! ?k" + using \ev = take (j - i) (drop i t) ! l\ by blast + moreover have "i \ ?k \ ?k < j" + using \l < length (take (j - i) (drop i t))\ by auto + ultimately show ?thesis by blast +qed + +lemma no_change_if_ge_length_t: + assumes + "trace init t final" and + "i \ length t" and + "j \ i" + shows + "S t i = S t j" +proof - + have "trace (S t i) (take (j - i) (drop i t)) (S t j)" + using assms(1) assms(3) exists_trace_for_any_i_j by blast + moreover have "(take (j - i) (drop i t)) = Nil" + by (simp add: assms(2)) + ultimately show ?thesis + by (metis tr_init trace_and_start_determines_end) +qed + +lemma no_marker_if_no_snapshot: + shows + "\ trace init t final; channel cid = Some (p, q); + ~ has_snapshotted (S t i) p \ + \ Marker \ set (msgs (S t i) cid)" +proof (induct i) + case 0 + then show ?case + by (metis exists_trace_for_any_i no_initial_Marker take_eq_Nil tr_init trace_and_start_determines_end) +next + case (Suc n) + then have IH: "Marker \ set (msgs (S t n) cid)" + by (meson distributed_system.exists_trace_for_any_i_j distributed_system.snapshot_stable_2 distributed_system_axioms eq_iff le_Suc_eq) + then obtain tr where decomp: "trace (S t n) tr (S t (Suc n))" "tr = take (Suc n - n) (drop n t)" + using Suc exists_trace_for_any_i_j le_Suc_eq by blast + have "Marker \ set (msgs (S t (Suc n)) cid)" + proof (cases "tr = []") + case True + then show ?thesis + by (metis IH decomp(1) tr_init trace_and_start_determines_end) + next + case False + then obtain ev where step: "tr = [ev]" "(S t n) \ ev \ (S t (Suc n))" + by (metis One_nat_def Suc_eq_plus1 Suc_leI \tr = take (Suc n - n) (drop n t)\ \trace (S t n) tr (S t (Suc n))\ add_diff_cancel_left' append.simps(1) butlast_take cancel_comm_monoid_add_class.diff_cancel length_greater_0_conv list.distinct(1) list.sel(3) snoc_eq_iff_butlast take0 take_Nil trace.cases) + then show ?thesis + proof (cases ev) + case (Snapshot p') + then show ?thesis + by (metis IH Suc.prems(2) Suc.prems(3) local.step(2) new_Marker_in_set_implies_nonregular_occurence new_msg_in_set_implies_occurrence nonregular_event_induces_snapshot snapshot_state_unchanged) + next + case (RecvMarker cid' p' q') + have "p' \ p" + proof (rule ccontr) + assume asm: "~ p' \ p" + then have "has_snapshotted (S t (Suc n)) p" + proof - + have "~ regular_event ev" using RecvMarker by auto + moreover have "occurs_on ev = p" using asm RecvMarker by auto + ultimately show ?thesis using step(2) Suc.hyps Suc.prems + by (metis nonregular_event_induces_snapshot snapshot_state_unchanged) + qed + then show False using Suc.prems by blast + qed + moreover have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "hd (msgs (S t n) cid) = Marker \ length (msgs (S t n) cid) > 0" + using step RecvMarker can_occur_def by auto + then have "Marker : set (msgs (S t n) cid)" + using list.set_sel(1) by fastforce + then show False using IH by simp + qed + ultimately have "msgs (S t (Suc n)) cid = msgs (S t n) cid" + proof - + have "\r. channel cid = Some (p', r)" + using Suc.prems(2) \p' \ p\ by auto + with `cid \ cid'` RecvMarker step show ?thesis by (cases "has_snapshotted (S t n) p'", auto) + qed + then show ?thesis by (simp add: IH) + next + case (Trans p' s s') + then show ?thesis + using IH local.step(2) by force + next + case (Send cid' p' q' s s' m) + with step IH show ?thesis by (cases "cid' = cid", auto) + next + case (Recv cid' p' q' s s' m) + with step IH show ?thesis by (cases "cid' = cid", auto) + qed + qed + then show ?case by blast +qed + +subsection \Termination\ + +text \We prove that the snapshot algorithm terminates, as exhibited +by lemma \texttt{snapshot\_algorithm\_must\_terminate}. In the final configuration all +processes have snapshotted, and no markers remain in the channels.\ + +lemma must_exist_snapshot: + assumes + "trace init t final" + shows + "\p i. Snapshot p = t ! i" +proof (rule ccontr) + assume "\p i. Snapshot p = t ! i" + have "\i p. ~ has_snapshotted (S t i) p" + proof (rule allI) + fix i + show "\p. ~ has_snapshotted (S t i) p" + proof (induct i) + case 0 + then show ?case + by (metis assms distributed_system.trace_and_start_determines_end distributed_system_axioms exists_trace_for_any_i computation.no_initial_process_snapshot computation_axioms take0 tr_init) + next + case (Suc n) + then have IH: "\p. ~ has_snapshotted (S t n) p" by auto + then obtain tr where "trace (S t n) tr (S t (Suc n))" "tr = take (Suc n - n) (drop n t)" + using assms exists_trace_for_any_i_j le_Suc_eq by blast + show "\p. ~ has_snapshotted (S t (Suc n)) p" + proof (cases "tr = []") + case True + then show ?thesis + by (metis IH \trace (S t n) tr (S t (Suc n))\ tr_init trace_and_start_determines_end) + next + case False + then obtain ev where step: "tr = [ev]" "(S t n) \ ev \ (S t (Suc n))" + by (metis One_nat_def Suc_eq_plus1 Suc_leI \tr = take (Suc n - n) (drop n t)\ \trace (S t n) tr (S t (Suc n))\ add_diff_cancel_left' append.simps(1) butlast_take cancel_comm_monoid_add_class.diff_cancel length_greater_0_conv list.distinct(1) list.sel(3) snoc_eq_iff_butlast take0 take_Nil trace.cases) + then show ?thesis + using step Suc.hyps proof (cases ev) + case (Snapshot q) + then show ?thesis + by (metis \\p i. Snapshot p = t ! i\ \tr = [ev]\ \tr = take (Suc n - n) (drop n t)\ append_Cons append_take_drop_id nth_append_length) + next + case (RecvMarker cid' q r) + then have m: "Marker \ set (msgs (S t n) cid')" + using RecvMarker_implies_Marker_in_set step by blast + have "~ has_snapshotted (S t n) q" using Suc by auto + then have "Marker \ set (msgs (S t n) cid')" + proof - + have "channel cid' = Some (r, q)" using step can_occur_def RecvMarker by auto + then show ?thesis + using IH assms no_marker_if_no_snapshot by blast + qed + then show ?thesis using m by auto + qed auto + qed + qed + qed + obtain j p where "has_snapshotted (S t j) p" using l2 assms by blast + then show False + using \\i p. \ has_snapshotted (S t i) p\ by blast +qed + +lemma recv_marker_means_snapshotted: + assumes + "trace init t final" and + "ev = RecvMarker cid p q" and + "(S t i) \ ev \ (S t (Suc i))" + shows + "has_snapshotted (S t i) q" +proof - + have "Marker = hd (msgs (S t i) cid) \ length (msgs (S t i) cid) > 0" + proof - + have "Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid" + using assms(2) assms(3) next_recv_marker by blast + then show ?thesis + by (metis length_greater_0_conv list.discI list.sel(1)) + qed + then have "Marker \ set (msgs (S t i) cid)" + using hd_in_set by fastforce + then show "has_snapshotted (S t i) q" + proof - + have "channel cid = Some (q, p)" using assms can_occur_def by auto + then show ?thesis + using \Marker \ set (msgs (S t i) cid)\ assms(1) no_marker_if_no_snapshot by blast + qed +qed + +lemma recv_marker_means_cs_Done: + assumes + "trace init t final" and + "t ! i = RecvMarker cid p q" and + "i < length t" + shows + "snd (cs (S t (i+1)) cid) = Done" +proof - + have "(S t i) \ (t ! i) \ (S t (i+1))" + using assms(1) assms(3) step_Suc by auto + then show ?thesis + by (simp add: assms(2)) +qed + +lemma snapshot_produces_marker: + assumes + "trace init t final" and + "~ has_snapshotted (S t i) p" and + "has_snapshotted (S t (Suc i)) p" and + "channel cid = Some (p, q)" + shows + "Marker : set (msgs (S t (Suc i)) cid) \ has_snapshotted (S t i) q" +proof - + obtain ev where ex_ev: "(S t i) \ ev \ (S t (Suc i))" + by (metis append_Nil2 append_take_drop_id assms(1) assms(2) assms(3) distributed_system.step_Suc distributed_system_axioms drop_eq_Nil less_Suc_eq_le nat_le_linear not_less_eq s_def) + then have "occurs_on ev = p" + using assms(2) assms(3) no_state_change_if_no_event by force + then show ?thesis + using assms ex_ev proof (cases ev) + case (Snapshot r) + then have "Marker \ set (msgs (S t (Suc i)) cid)" + using ex_ev assms(2) assms(3) assms(4) by fastforce + then show ?thesis by simp + next + case (RecvMarker cid' r s) + have "r = p" using `occurs_on ev = p` + by (simp add: RecvMarker) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "has_snapshotted (S t i) q" + using RecvMarker RecvMarker_implies_Marker_in_set assms(1) assms(2) assms(4) ex_ev no_marker_if_no_snapshot by blast + then show ?thesis by simp + next + case False + then have "\s. channel cid = Some (r, s)" using RecvMarker assms can_occur_def `r = p` by simp + then have "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Marker]" + using RecvMarker assms ex_ev `r = p` False by simp + then show ?thesis by simp + qed + qed auto +qed + +lemma exists_snapshot_for_all_p: + assumes + "trace init t final" + shows + "\i. ~ has_snapshotted (S t i) p \ has_snapshotted (S t (Suc i)) p" (is ?Q) +proof - + obtain i where "has_snapshotted (S t i) p" using l2 assms by blast + let ?j = "LEAST j. has_snapshotted (S t j) p" + have "?j \ 0" + proof - + have "~ has_snapshotted (S t 0) p" + by (metis exists_trace_for_any_i list.discI no_initial_process_snapshot s_def take_eq_Nil trace.simps) + then show ?thesis + by (metis (mono_tags, lifting) \has_snapshotted (S t i) p\ wellorder_Least_lemma(1)) + qed + have "?j \ i" + by (meson Least_le \has_snapshotted (S t i) p\) + have "\ has_snapshotted (S t (?j - 1)) p" (is ?P) + proof (rule ccontr) + assume "\ ?P" + then have "has_snapshotted (S t (?j - 1)) p" by simp + then have "\j. j < ?j \ has_snapshotted (S t j) p" + by (metis One_nat_def \(LEAST j. ps (S t j) p \ None) \ 0\ diff_less lessI not_gr_zero) + then show False + using not_less_Least by blast + qed + show ?thesis + proof (rule ccontr) + assume "\ ?Q" + have "\i. \ has_snapshotted (S t i) p" + proof (rule allI) + fix i' + show "\ has_snapshotted (S t i') p" + proof (induct i') + case 0 + then show ?case + using \(LEAST j. ps (S t j) p \ None) \ 0\ by force + next + case (Suc i'') + then show ?case + using \\i. \ ps (S t i) p \ None \ ps (S t (Suc i)) p \ None\ by blast + qed + qed + then show False + using \ps (S t i) p \ None\ by blast + qed +qed + +lemma all_processes_snapshotted_in_final_state: + assumes + "trace init t final" + shows + "has_snapshotted final p" +proof - + obtain i where "has_snapshotted (S t i) p \ i \ length t" + using assms l2 by blast + moreover have "final = (S t (length t))" + by (metis (no_types, lifting) assms exists_trace_for_any_i le_Suc_eq length_Cons take_Nil take_all trace.simps trace_and_start_determines_end) + ultimately show ?thesis + using assms exists_trace_for_any_i_j snapshot_stable by blast +qed + +definition next_marker_free_state where + "next_marker_free_state t i cid = (LEAST j. j \ i \ Marker \ set (msgs (S t j) cid))" + +lemma exists_next_marker_free_state: + assumes + "channel cid = Some (p, q)" + "trace init t final" + shows + "\!j. next_marker_free_state t i cid = j \ j \ i \ Marker \ set (msgs (S t j) cid)" +proof (cases "Marker \ set (msgs (S t i) cid)") + case False + then have "next_marker_free_state t i cid = i" unfolding next_marker_free_state_def + by (metis (no_types, lifting) Least_equality order_refl) + then show ?thesis using False assms by blast +next + case True + then obtain j where "j \ i" "Marker \ set (msgs (S t j) cid)" using l1 assms by blast + then show ?thesis + by (metis (no_types, lifting) LeastI_ex next_marker_free_state_def) +qed + +theorem snapshot_algorithm_must_terminate: + assumes + "trace init t final" + shows + "\phi. ((\p. has_snapshotted (S t phi) p) + \ (\cid. Marker \ set (msgs (S t phi) cid)))" +proof - + let ?i = "{i. i \ length t \ (\p. has_snapshotted (S t i) p)}" + have fin_i: "finite ?i" by auto + moreover have "?i \ empty" + proof - + have "\p. has_snapshotted (S t (length t)) p" + by (meson assms exists_trace_for_any_i_j l2 snapshot_stable_2) + then show ?thesis by blast + qed + then obtain i where asm: "\p. has_snapshotted (S t i) p" by blast + have f: "\j. j \ i \ (\p. has_snapshotted (S t j) p)" + using snapshot_stable asm exists_trace_for_any_i_j valid assms by blast + let ?s = "(\cid. (next_marker_free_state t i cid)) ` { cid. channel cid \ None }" + have "?s \ empty" using exists_some_channel by auto + have fin_s: "finite ?s" using finite_channels by simp + let ?phi = "Max ?s" + have "?phi \ i" + proof (rule ccontr) + assume asm: "\ ?phi \ i" + obtain cid p q where g: "channel cid = Some (p, q)" using exists_some_channel by auto + then have "next_marker_free_state t i cid \ i" using exists_next_marker_free_state assms by blast + then have "Max ?s \ i" using Max_ge_iff g fin_s by fast + then show False using asm by simp + qed + then have "\cid. Marker \ set (msgs (S t ?phi) cid)" + proof - + fix cid + show "Marker \ set (msgs (S t ?phi) cid)" + proof (cases "Marker : set (msgs (S t i) cid)") + case False + then show ?thesis + using \i \ Max ?s\ asm assms exists_trace_for_any_i_j no_markers_if_all_snapshotted by blast + next + case True + then have cpq: "channel cid \ None" using no_messages_if_no_channel assms by fastforce + then obtain p q where chan: "channel cid = Some (p, q)" by auto + then obtain j where i: "j = next_marker_free_state t i cid" "Marker \ set (msgs (S t j) cid)" + using exists_next_marker_free_state assms by fast + have "j \ ?phi" using cpq fin_s i(1) pair_imageI by simp + then show "Marker \ set (msgs (S t ?phi) cid)" + proof - + have "trace (S t j) (take (?phi - j) (drop j t)) (S t ?phi)" + using \j \ ?phi\ assms exists_trace_for_any_i_j by blast + moreover have "\p. has_snapshotted (S t j) p" + by (metis assms chan f computation.exists_next_marker_free_state computation_axioms i(1)) + ultimately show ?thesis + using i(2) no_markers_if_all_snapshotted by blast + qed + qed + qed + thus ?thesis using f `?phi \ i` by blast +qed + +subsection \Correctness\ + +text \The greatest part of this work is spent on the correctness +of the Chandy-Lamport algorithm. We prove that the snapshot is +consistent, i.e.\ there exists a permutation $t'$ of the trace $t$ and an intermediate +configuration $c'$ of $t'$ such that the configuration recorded in the snapshot +corresponds to the snapshot taken during execution of $t$, which is given as Theorem 1 +in~\cite{chandy}.\ + +lemma snapshot_stable_ver_2: + shows "trace init t final \ has_snapshotted (S t i) p \ j \ i \ has_snapshotted (S t j) p" + using exists_trace_for_any_i_j snapshot_stable by blast + +lemma snapshot_stable_ver_3: + shows "trace init t final \ ~ has_snapshotted (S t i) p \ i \ j \ ~ has_snapshotted (S t j) p" + using snapshot_stable_ver_2 by blast + +lemma marker_must_stay_if_no_snapshot: + assumes + "trace init t final" and + "has_snapshotted (S t i) p" and + "~ has_snapshotted (S t i) q" and + "channel cid = Some (p, q)" + shows + "Marker : set (msgs (S t i) cid)" +proof - + obtain j where "~ has_snapshotted (S t j) p \ has_snapshotted (S t (Suc j)) p" + using exists_snapshot_for_all_p assms by blast + have "j \ i" + proof (rule ccontr) + assume asm: "~ j \ i" + then have "~ has_snapshotted (S t i) p" + using \\ has_snapshotted (S t j) p \ has_snapshotted (S t (Suc j)) p\ assms(1) less_imp_le_nat snapshot_stable_ver_3 + by (meson nat_le_linear) + then show False using assms(2) by simp + qed + have "i \ length t" + proof (rule ccontr) + assume "~ i \ length t" + then have "i > length t" + using not_less by blast + obtain i' where a: "\p. has_snapshotted (S t i') p" using assms snapshot_algorithm_must_terminate by blast + have "i' \ i" + using \\p. has_snapshotted (S t i') p\ assms(1) assms(3) nat_le_linear snapshot_stable_ver_3 by blast + have "(S t i') \ (S t i)" using assms a by force + then have "i \ length t" + using \i \ i'\ assms(1) computation.no_change_if_ge_length_t computation_axioms nat_le_linear by fastforce + then show False using `~ i \ length t` by simp + qed + have marker_in_set: "Marker : set (msgs (S t (Suc j)) cid)" + using \\ has_snapshotted (S t j) p \ has_snapshotted (S t (Suc j)) p\ \j \ i\ assms(1) assms(3) assms(4) snapshot_produces_marker snapshot_stable_ver_3 by blast + show ?thesis + proof (rule ccontr) + assume asm: "Marker \ set (msgs (S t i) cid)" + then have range: "(Suc j) < i" + by (metis Suc_lessI \\ ps (S t j) p \ None \ ps (S t (Suc j)) p \ None\ \j \ i\ assms(2) marker_in_set order.order_iff_strict) + let ?k = "LEAST k. k \ (Suc j) \ Marker \ set (msgs (S t k) cid)" + have range_k: "(Suc j) < ?k \ ?k \ i" + proof - + have "j < (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid))" + by (metis (full_types) Suc_le_eq assms(1) assms(4) exists_next_marker_free_state next_marker_free_state_def) + then show ?thesis + proof - + assume a1: "j < (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid))" + have "j < i" + using local.range by linarith (* 4 ms *) + then have "(Suc j \ i \ Marker \ set (msgs (S t i) cid)) \ (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) \ Suc j" + by (metis (lifting) Suc_leI asm marker_in_set wellorder_Least_lemma(1)) (* 64 ms *) + then show ?thesis + using a1 by (simp add: wellorder_Least_lemma(2)) (* 16 ms *) + qed + qed + have a: "Marker : set (msgs (S t (?k-1)) cid)" + proof - + obtain nn :: "nat \ nat \ nat" where + "\x0 x1. (\v2. x0 = Suc (x1 + v2)) = (x0 = Suc (x1 + nn x0 x1))" + by moura + then have f1: "(LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) = Suc (Suc j + nn (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) (Suc j))" + using \Suc j < (LEAST k. Suc j \ k \ Marker \ set (msgs (S t k) cid)) \ (LEAST k. Suc j \ k \ Marker \ set (msgs (S t k) cid)) \ i\ less_iff_Suc_add by fastforce + have f2: "Suc j \ Suc j + nn (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) (Suc j)" + by simp + have f3: "\p n. \ p (n::nat) \ Least p \ n" + by (meson wellorder_Least_lemma(2)) + have "\ (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) \ Suc j + nn (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) (Suc j)" + using f1 by linarith + then have f4: "\ (Suc j \ Suc j + nn (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) (Suc j) \ Marker \ set (msgs (S t (Suc j + nn (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) (Suc j))) cid))" + using f3 by force + have "Suc j + nn (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) (Suc j) = (LEAST n. Suc j \ n \ Marker \ set (msgs (S t n) cid)) - 1" + using f1 by linarith + then show ?thesis + using f4 f2 by presburger + qed + have b: "Marker \ set (msgs (S t ?k) cid)" + using assms(1) assms(4) exists_next_marker_free_state next_marker_free_state_def by fastforce + have "?k - 1 < i" using range_k by auto + then obtain ev where step: "(S t (?k-1)) \ ev \ (S t (Suc (?k-1)))" + by (meson Suc_le_eq \i \ length t\ assms(1) le_trans step_Suc) + then show False + using a assms(1) assms(3) assms(4) b computation.snapshot_stable_ver_3 computation_axioms less_iff_Suc_add range_k recv_marker_means_snapshotted_2 by fastforce + qed +qed + +subsubsection \Pre- and postrecording events\ + +definition prerecording_event: + "prerecording_event t i \ + i < length t \ regular_event (t ! i) + \ ~ has_snapshotted (S t i) (occurs_on (t ! i))" + +definition postrecording_event: + "postrecording_event t i \ + i < length t \ regular_event (t ! i) + \ has_snapshotted (S t i) (occurs_on (t ! i))" + +abbreviation neighboring where + "neighboring t i j \ i < j \ j < length t \ regular_event (t ! i) \ regular_event (t ! j) + \ (\k. i < k \ k < j \ ~ regular_event (t ! k))" + +lemma pre_if_regular_and_not_post: + assumes + "regular_event (t ! i)" and + "~ postrecording_event t i" and + "i < length t" + shows + "prerecording_event t i" + using assms computation.postrecording_event computation_axioms prerecording_event by metis + +lemma post_if_regular_and_not_pre: + assumes + "regular_event (t ! i)" and + "~ prerecording_event t i" and + "i < length t" + shows + "postrecording_event t i" + using assms computation.postrecording_event computation_axioms prerecording_event by metis + +lemma post_before_pre_different_processes: + assumes + "i < j" and + "j < length t" and + neighboring: "\k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + post_ei: "postrecording_event t i" and + pre_ej: "prerecording_event t j" and + valid: "trace init t final" + shows + "occurs_on (t ! i) \ occurs_on (t ! j)" +proof - + let ?p = "occurs_on (t ! i)" + let ?q = "occurs_on (t ! j)" + have sp: "has_snapshotted (S t i) ?p" + using assms postrecording_event prerecording_event by blast + have nsq: "~ has_snapshotted (S t j) ?q" + using assms postrecording_event prerecording_event by blast + show "?p \ ?q" + proof - + have "~ has_snapshotted (S t i) ?q" + proof (rule ccontr) + assume sq: "~ ~ has_snapshotted (S t i) ?q" + from `i < j` have "i \ j" using less_imp_le by blast + then obtain tr where ex_trace: "trace (S t i) tr (S t j)" + using exists_trace_for_any_i_j valid by blast + then have "has_snapshotted (S t j) ?q" using ex_trace snapshot_stable sq by blast + then show False using nsq by simp + qed + then show ?thesis using sp by auto + qed +qed + +lemma post_before_pre_neighbors: + assumes + "i < j" and + "j < length t" and + neighboring: "\k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + post_ei: "postrecording_event t i" and + pre_ej: "prerecording_event t j" and + valid: "trace init t final" + shows + "Ball (set (take (j - (i+1)) (drop (i+1) t))) (%ev. ~ regular_event ev \ ~ occurs_on ev = occurs_on (t ! j))" +proof - + let ?p = "occurs_on (t ! i)" + let ?q = "occurs_on (t ! j)" + let ?between = "take (j - (i+1)) (drop (i+1) t)" + show ?thesis + proof (unfold Ball_def, rule allI, rule impI) + fix ev + assume "ev : set ?between" + have len_nr: "length ?between = (j - (i+1))" using assms(2) by auto + then obtain l where "?between ! l = ev" and range_l: "0 \ l \ l < (j - (i+1))" + by (metis \ev \ set (take (j - (i + 1)) (drop (i + 1) t))\ gr_zeroI in_set_conv_nth le_numeral_extra(3) less_le) + let ?k = "l + (i+1)" + have "?between ! l = (t ! ?k)" + proof - + have "j < length t" + by (metis assms(2)) + then show ?thesis + by (metis (no_types) Suc_eq_plus1 Suc_leI add.commute assms(1) drop_take length_take less_diff_conv less_imp_le_nat min.absorb2 nth_drop nth_take range_l) + qed + have "~ regular_event ev" + by (metis (no_types, lifting) assms(3) range_l One_nat_def Suc_eq_plus1 \take (j - (i + 1)) (drop (i + 1) t) ! l = ev\ \take (j - (i + 1)) (drop (i + 1) t) ! l = t ! (l + (i + 1))\ add.left_commute add_lessD1 lessI less_add_same_cancel2 less_diff_conv order_le_less) + have step_ev: "(S t ?k) \ ev \ (S t (?k+1))" + proof - + have "j \ length t" + by (metis assms(2) less_or_eq_imp_le) + then have "l + (i + 1) < length t" + by (meson less_diff_conv less_le_trans range_l) + then show ?thesis + by (metis (no_types) Suc_eq_plus1 \take (j - (i + 1)) (drop (i + 1) t) ! l = ev\ \take (j - (i + 1)) (drop (i + 1) t) ! l = t ! (l + (i + 1))\ distributed_system.step_Suc distributed_system_axioms valid) + qed + obtain cid s r where f: "ev = RecvMarker cid s r \ ev = Snapshot r" using `~ regular_event ev` + by (meson isRecvMarker_def isSnapshot_def nonregular_event) + from f have "occurs_on ev \ ?q" + proof (elim disjE) + assume snapshot: "ev = Snapshot r" + show ?thesis + proof (rule ccontr) + assume occurs_on_q: "~ occurs_on ev \ ?q" + then have "?q = r" using snapshot by auto + then have q_snapshotted: "has_snapshotted (S t (?k+1)) ?q" + using snapshot step_ev by auto + then show False + proof - + have "l + (i + 1) < j" + by (meson less_diff_conv range_l) + then show ?thesis + by (metis (no_types) Suc_eq_plus1 Suc_le_eq computation.snapshot_stable_ver_2 computation_axioms pre_ej prerecording_event q_snapshotted valid) + qed + qed + next + assume RecvMarker: "ev = RecvMarker cid s r" + show ?thesis + proof (rule ccontr) + assume occurs_on_q: "~ occurs_on ev \ ?q" + then have "s = ?q" using RecvMarker by auto + then have q_snapshotted: "has_snapshotted (S t (?k+1)) ?q" + proof (cases "has_snapshotted (S t ?k) ?q") + case True + then show ?thesis using snapshot_stable_ver_2 step_Suc step_ev valid by auto + next + case False + then show "has_snapshotted (S t (?k+1)) ?q" + using \s = ?q\ next_recv_marker RecvMarker step_ev by auto + qed + then show False + proof - + have "l + (i + 1) < j" + using less_diff_conv range_l by blast + then show ?thesis + by (metis (no_types) Suc_eq_plus1 Suc_le_eq computation.snapshot_stable_ver_2 computation_axioms pre_ej prerecording_event q_snapshotted valid) + qed + qed + qed + then show "\ regular_event ev \ occurs_on ev \ ?q" + using `~ regular_event ev` by simp + qed +qed + +lemma can_swap_neighboring_pre_and_postrecording_events: + assumes + "i < j" and + "j < length t" and + "occurs_on (t ! i) = p" and + "occurs_on (t ! j) = q" and + neighboring: "\k. (i < k \ k < j) + \ ~ regular_event (t ! k)" and + post_ei: "postrecording_event t i" and + pre_ej: "prerecording_event t j" and + valid: "trace init t final" + shows + "can_occur (t ! j) (S t i)" +proof - + have "p \ q" using post_before_pre_different_processes assms by auto + have sp: "has_snapshotted (S t i) p" + using assms(3) post_ei postrecording_event prerecording_event by blast + have nsq: "~ has_snapshotted (S t j) q" + using assms(4) pre_ej prerecording_event by auto + let ?nr = "take (j - (Suc i)) (drop (Suc i) t)" + have valid_subtrace: "trace (S t (Suc i)) ?nr (S t j)" + using assms(1) exists_trace_for_any_i_j valid by fastforce + have "Ball (set ?nr) (%ev. ~ occurs_on ev = q \ ~ regular_event ev)" + proof - + have "?nr = take (j - (i+1)) (drop (i+1) t)" by auto + then show ?thesis + by (metis assms(1) assms(2) assms(4) neighboring post_ei pre_ej valid post_before_pre_neighbors) + qed + then have la: "list_all (%ev. ~ occurs_on ev = q) ?nr" + by (meson list_all_length nth_mem) + have tj_to_tSi: "can_occur (t ! j) (S t (Suc i))" + proof - + have "list_all (%ev. ~ isSend ev) ?nr" + proof - + have "list_all (%ev. ~ regular_event ev) ?nr" + using \\ev\set (take (j - (Suc i)) (drop (Suc i) t)). occurs_on ev \ q \ \ regular_event ev\ \list_all (\ev. occurs_on ev \ q) (take (j - (Suc i)) (drop (Suc i) t))\ list.pred_mono_strong by fastforce + then show ?thesis + by (simp add: list.pred_mono_strong) + qed + moreover have "~ isRecvMarker (t ! j)" using prerecording_event assms by auto + moreover have "can_occur (t ! j) (S t j)" + proof - + have "(S t j) \ (t ! j) \ (S t (Suc j))" + using assms(2) step_Suc valid by auto + then show ?thesis + using happen_implies_can_occur by blast + qed + ultimately show "can_occur (t ! j) (S t (Suc i))" + using assms(4) event_can_go_back_if_no_sender_trace valid_subtrace la by blast + qed + show "can_occur (t ! j) (S t i)" + proof (cases "isSend (t ! i)") + case False + have "~ isRecvMarker (t ! j)" using assms prerecording_event by auto + moreover have "~ isSend (t ! i)" using False by simp + ultimately show ?thesis + by (metis \p \ q\ assms(3) assms(4) event_can_go_back_if_no_sender post_ei postrecording_event step_Suc tj_to_tSi valid) + next + case True + obtain cid s u u' m where Send: "t ! i = Send cid p s u u' m" + by (metis True isSend_def assms(3) event.sel(2)) + have chan: "channel cid = Some (p, s)" + proof - + have "can_occur (t ! i) (S t i)" + by (meson computation.postrecording_event computation_axioms happen_implies_can_occur post_ei step_Suc valid) + then show ?thesis using can_occur_def Send by simp + qed + have n: "(S t i) \ (t ! i) \ (S t (Suc i))" + using assms(1) assms(2) step_Suc valid True by auto + have st: "states (S t i) q = states (S t (Suc i)) q" + using Send \p \ q\ n by auto + have "isTrans (t ! j) \ isSend (t ! j) \ isRecv (t ! j)" + using assms(7) computation.prerecording_event computation_axioms regular_event by blast + then show ?thesis + proof (elim disjE) + assume "isTrans (t ! j)" + then show ?thesis + by (metis (no_types, lifting) tj_to_tSi st can_occur_def assms(4) event.case(1) event.collapse(1)) + next + assume "isSend (t ! j)" + then obtain cid' s' u'' u''' m' where Send: "t ! j = Send cid' q s' u'' u''' m'" + by (metis (no_types, lifting) assms(4) event.sel(2) isSend_def) + have co_tSi: "can_occur (Send cid' q s' u'' u''' m') (S t (Suc i))" + using Send tj_to_tSi by auto + then have "channel cid' = Some (q, s') \ send cid' q s' u'' u''' m'" + using Send can_occur_def by simp + then show ?thesis using can_occur_def st Send assms co_tSi by auto + next + assume "isRecv (t ! j)" + then obtain cid' s' u'' u''' m' where Recv: "t ! j = Recv cid' q s' u'' u''' m'" + by (metis assms(4) event.sel(3) isRecv_def) + have co_tSi: "can_occur (Recv cid' q s' u'' u''' m') (S t (Suc i))" + using Recv tj_to_tSi by auto + then have a: "channel cid' = Some (s', q) \ length (msgs (S t (Suc i)) cid') > 0 + \ hd (msgs (S t (Suc i)) cid') = Msg m'" + using can_occur_def co_tSi by fastforce + show "can_occur (t ! j) (S t i)" + proof (cases "cid = cid'") + case False + with Send n have "msgs (S t (Suc i)) cid' = msgs (S t i) cid'" by auto + then have b: "length (msgs (S t i) cid') > 0 \ hd (msgs (S t i) cid') = Msg m'" + using a by simp + with can_occur_Recv co_tSi st a Recv show ?thesis + unfolding can_occur_def by auto + next + case True (* This is the interesting case *) + have stu: "states (S t i) q = u''" + using can_occur_Recv co_tSi st by blast + show ?thesis + proof (rule ccontr) + have marker_in_set: "Marker \ set (msgs (S t i) cid)" + proof - + have "(s', q) = (p, q)" + using True a chan by auto + then show ?thesis + by (metis (no_types, lifting) True \p \ q\ a assms(3) marker_must_stay_if_no_snapshot n no_state_change_if_no_event nsq snapshot_stable_2 sp valid valid_subtrace) + qed + assume asm: "~ can_occur (t ! j) (S t i)" + then show False + proof (unfold can_occur_def, (auto simp add: marker_in_set True Recv stu)) + assume "msgs (S t i) cid' = []" + then show False using marker_in_set + by (simp add: True) + next + assume "hd (msgs (S t i) cid') \ Msg m'" + have "msgs (S t i) cid \ []" using marker_in_set by auto + then have "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Msg m]" + using Send True n chan by auto + then have "hd (msgs (S t (Suc i)) cid) \ Msg m'" + using True \hd (msgs (S t i) cid') \ Msg m'\ \msgs (S t i) cid \ []\ by auto + then have "~ can_occur (t ! j) (S t (Suc i))" + using True a by blast + then show False + using tj_to_tSi by blast + next + assume "~ recv cid' q s' u'' u''' m'" + then show False + using can_occur_Recv co_tSi by blast + next + assume "channel cid' \ Some (s', q)" + then show False using can_occur_def tj_to_tSi Recv by simp + qed + qed + qed + qed + qed +qed + +subsubsection \Event swapping\ + +lemma swap_events: + shows "\ i < j; j < length t; + \k. (i < k \ k < j) \ ~ regular_event (t ! k); + postrecording_event t i; prerecording_event t j; + trace init t final \ + \ trace init (swap_events i j t) final + \ (\k. k \ j + 1 \ S (swap_events i j t) k = S t k) + \ (\k. k \ i \ S (swap_events i j t) k = S t k) + \ prerecording_event (swap_events i j t) i + \ postrecording_event (swap_events i j t) (i+1) + \ (\k. k > i+1 \ k < j+1 + \ ~ regular_event ((swap_events i j t) ! k))" +proof (induct "j - (i+1)" arbitrary: j t) + case 0 + let ?p = "occurs_on (t ! i)" + let ?q = "occurs_on (t ! j)" + have "j = (i+1)" + using "0.prems" "0.hyps" by linarith + let ?subt = "take (j - (i+1)) (drop (i+1) t)" + have "t = take i t @ [t ! i] @ ?subt @ [t ! j] @ drop (j+1) t" + proof - + have "take (Suc i) t = take i t @ [t ! i]" + using "0.prems"(2) \j = i + 1\ add_lessD1 take_Suc_conv_app_nth by blast + then show ?thesis + by (metis (no_types) "0.hyps" "0.prems"(2) Suc_eq_plus1 \j = i + 1\ append_assoc append_take_drop_id self_append_conv2 take_Suc_conv_app_nth take_eq_Nil) + qed + have sp: "has_snapshotted (S t i) ?p" + using "0.prems" postrecording_event prerecording_event by blast + have nsq: "~ has_snapshotted (S t j) ?q" + using "0.prems" postrecording_event prerecording_event by blast + have "?p \ ?q" + using "0.prems" computation.post_before_pre_different_processes computation_axioms by blast + have "?subt = Nil" + by (simp add: \j = i + 1\) + have reg_step_1: "(S t i) \ (t ! i) \ (S t j)" + by (metis "0.prems"(2) "0.prems"(6) Suc_eq_plus1 \j = i + 1\ add_lessD1 step_Suc) + have reg_step_2: "(S t j) \ (t ! j) \ (S t (j+1))" + using "0.prems"(2) "0.prems"(6) step_Suc by auto + have "can_occur (t ! j) (S t i)" + using "0.prems" can_swap_neighboring_pre_and_postrecording_events by blast + then obtain d' where new_step1: "(S t i) \ (t ! j) \ d'" + using exists_next_if_can_occur by blast + + have st: "states d' ?p = states (S t i) ?p" + using \(S t i) \ t ! j \ d'\ \occurs_on (t ! i) \ occurs_on (t ! j)\ no_state_change_if_no_event by auto + then have "can_occur (t ! i) d'" + using \occurs_on (t ! i) \ occurs_on (t ! j)\ event_stays_valid_if_no_occurrence happen_implies_can_occur new_step1 reg_step_1 by auto + then obtain e where new_step2: "d' \ (t ! i) \ e" + using exists_next_if_can_occur by blast + + have "states e = states (S t (j+1))" + proof (rule ext) + fix p + show "states e p = states (S t (j+1)) p" + proof (cases "p = ?p \ p = ?q") + case True + then show ?thesis + proof (elim disjE) + assume "p = ?p" + then have "states d' p = states (S t i) p" + by (simp add: st) + thm same_state_implies_same_result_state + then have "states e p = states (S t j) p" + using "0.prems"(2) "0.prems"(6) new_step2 reg_step_1 by (blast intro:same_state_implies_same_result_state[symmetric]) + moreover have "states (S t j) p = states (S t (j+1)) p" + using \occurs_on (t ! i) \ occurs_on (t ! j)\ \p = occurs_on (t ! i)\ no_state_change_if_no_event reg_step_2 by auto + ultimately show ?thesis by simp + next + assume "p = ?q" + then have "states (S t j) p = states (S t i) p" + using reg_step_1 \occurs_on (t ! i) \ occurs_on (t ! j)\ no_state_change_if_no_event by auto + then have "states d' p = states (S t (j+1)) p" + using "0.prems"(5) prerecording_event computation_axioms new_step1 reg_step_2 same_state_implies_same_result_state by blast + moreover have "states e p = states (S t (j+1)) p" + using \occurs_on (t ! i) \ occurs_on (t ! j)\ \p = occurs_on (t ! j)\ calculation new_step2 no_state_change_if_no_event by auto + ultimately show ?thesis by simp + qed + next + case False + then have "states (S t i) p = states (S t j) p" + using no_state_change_if_no_event reg_step_1 by auto + moreover have "... = states (S t (j+1)) p" + using False no_state_change_if_no_event reg_step_2 by auto + moreover have "... = states d' p" + using False calculation new_step1 no_state_change_if_no_event by auto + moreover have "... = states e p" + using False new_step2 no_state_change_if_no_event by auto + ultimately show ?thesis by simp + qed + qed + + moreover have "msgs e = msgs (S t (j+1))" + proof (rule ext) + fix cid + have "isTrans (t ! i) \ isSend (t ! i) \ isRecv (t ! i)" + using "0.prems"(4) computation.postrecording_event computation_axioms regular_event by blast + moreover have "isTrans (t ! j) \ isSend (t ! j) \ isRecv (t ! j)" + using "0.prems"(5) computation.prerecording_event computation_axioms regular_event by blast + ultimately show "msgs e cid = msgs (S t (j+1)) cid" + proof (elim disjE, goal_cases) + case 1 + then have "msgs d' cid = msgs (S t j) cid" + by (metis Trans_msg new_step1 reg_step_1) + then show ?thesis + using Trans_msg \isTrans (t ! i)\ \isTrans (t ! j)\ new_step2 reg_step_2 by auto + next + case 2 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Trans_Send by auto + next + case 3 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Trans_Recv by auto + next + case 4 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Send_Trans by auto + next + case 5 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Recv_Trans by auto + next + case 6 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 by (blast intro:swap_msgs_Send_Send[symmetric]) + next + case 7 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Send_Recv by auto + next + case 8 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 swap_msgs_Send_Recv by simp + next + case 9 + then show ?thesis + using \occurs_on (t ! i) \ occurs_on (t ! j)\ new_step1 new_step2 reg_step_1 reg_step_2 by (blast intro:swap_msgs_Recv_Recv[symmetric]) + qed + qed + + moreover have "process_snapshot e = process_snapshot (S t (j+1))" + proof (rule ext) + fix p + have "process_snapshot d' p = process_snapshot (S t j) p" + by (metis "0.prems"(4) "0.prems"(5) computation.postrecording_event computation.prerecording_event computation_axioms new_step1 reg_step_1 regular_event_preserves_process_snapshots) + then show "process_snapshot e p = process_snapshot (S t (j+1)) p" + by (metis "0.prems"(4) "0.prems"(5) computation.postrecording_event computation.prerecording_event computation_axioms new_step2 reg_step_2 regular_event_preserves_process_snapshots) + qed + + moreover have "channel_snapshot e = channel_snapshot (S t (j+1))" + proof (rule ext) + fix cid + show "cs e cid = cs (S t (j+1)) cid" + proof (cases "isRecv (t ! i)"; cases "isRecv (t ! j)", goal_cases) + case 1 + then show ?thesis + using \?p \ ?q\ new_step1 new_step2 reg_step_1 reg_step_2 + by (blast intro:regular_event_implies_same_channel_snapshot_Recv_Recv[symmetric]) + next + case 2 + moreover have "regular_event (t ! j)" using prerecording_event 0 by simp + ultimately show ?thesis + using \?p \ ?q\ new_step1 new_step2 reg_step_1 reg_step_2 regular_event_implies_same_channel_snapshot_Recv by auto + next + assume 3: "~ isRecv (t ! i)" "isRecv (t ! j)" + moreover have "regular_event (t ! i)" using postrecording_event 0 by simp + ultimately show ?thesis + using \?p \ ?q\ new_step1 new_step2 reg_step_1 reg_step_2 regular_event_implies_same_channel_snapshot_Recv by auto + + next + assume 4: "~ isRecv (t ! i)" "~ isRecv (t ! j)" + moreover have "regular_event (t ! j)" using prerecording_event 0 by simp + moreover have "regular_event (t ! i)" using postrecording_event 0 by simp + ultimately show ?thesis + using \?p \ ?q\ new_step1 new_step2 reg_step_1 reg_step_2 + by (metis no_cs_change_if_no_event) + qed + qed + ultimately have "e = S t (j+1)" by simp + then have "(S t i) \ (t ! j) \ d' \ d' \ (t ! i) \ (S t (j+1))" + using new_step1 new_step2 by blast + then have swap: "trace (S t i) [t ! j, t ! i] (S t (j+1))" + by (meson trace.simps) + have "take (j-1) t @ [t ! j, t ! i] = ((take (j+1) t)[i := t ! j])[j := t ! i]" + proof - + have "i = j - 1" + by (simp add: \j = i + 1\) + show ?thesis + proof (subst (1 2 3) `i = j - 1`) + have "j < length t" using "0.prems" by auto + then have "take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t = t[j - 1 := t ! j, j := t ! (j - 1)]" + by (metis Suc_eq_plus1 \i = j - 1\ \j = i + 1\ add_Suc_right arith_special(3) swap_neighbors) + then show "take (j - 1) t @ [t ! j, t ! (j - 1)] = (take (j+1) t)[j - 1 := t ! j, j := t ! (j - 1)]" + proof - + assume a1: "take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t = t [j - 1 := t ! j, j := t ! (j - 1)]" + have f2: "t[j - 1 := t ! j, j := t ! (j - 1)] = take j (t[j - 1 := t ! j]) @ t ! (j - 1) # drop (Suc j) (t[j - 1 := t ! j])" + by (metis (no_types) "0.prems"(2) length_list_update upd_conv_take_nth_drop) (* 32 ms *) + have f3: "\n na. \ n < na \ Suc n \ na" + using Suc_leI by blast (* 0.0 ms *) + then have "min (length t) (j + 1) = j + 1" + by (metis (no_types) "0.prems"(2) Suc_eq_plus1 min.absorb2) (* 16 ms *) + then have f4: "length ((take (j + 1) t)[j - 1 := t ! j]) = j + 1" + by simp (* 4 ms *) + have f5: "j + 1 \ length (t[j - 1 := t ! j])" + using f3 by (metis (no_types) "0.prems"(2) Suc_eq_plus1 length_list_update) (* 8 ms *) + have "Suc j \ j + 1" + by linarith (* 0.0 ms *) + then have "(take (j + 1) (t[j - 1 := t ! j]))[j := t ! (j - 1)] = take j (t[j - 1 := t ! j]) @ t ! (j - 1) # [] @ []" + using f5 f4 by (metis (no_types) Suc_eq_plus1 add_diff_cancel_right' butlast_conv_take butlast_take drop_eq_Nil lessI self_append_conv2 take_update_swap upd_conv_take_nth_drop) (* 180 ms *) + then show ?thesis + using f2 a1 by (simp add: take_update_swap) (* 120 ms *) + qed + qed + qed + have s: "trace init (take i t) (S t i)" + using "0.prems"(6) exists_trace_for_any_i by blast + have e: "trace (S t (j+1)) (take (length t - (j+1)) (drop (j+1) t)) final" + proof - + have "trace init (take (length t) t) final" + by (simp add: "0.prems"(6)) + then show ?thesis + by (metis "0.prems"(2) Suc_eq_plus1 Suc_leI exists_trace_for_any_i exists_trace_for_any_i_j nat_le_linear take_all trace_and_start_determines_end) + qed + have "trace init (take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) final" + proof - + from s swap have "trace init (take i t @ [t ! j,t ! i]) (S t (j+1))" using trace_trans by blast + then have "trace init (take i t @ [t ! j, t ! i] @ (take (length t - (j+1)) (drop (j+1) t))) final" + using e trace_trans by fastforce + moreover have "take (length t - (j+1)) (drop (j+1) t) = drop (j+1) t" by simp + ultimately show ?thesis by simp + qed + moreover have "take i t @ [t ! j] @ [t ! i] @ drop (j+1) t = (t[i := t ! j])[j := t ! i]" + proof - + have "length (take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) = length ((t[i := t ! j])[j := t ! i])" + by (metis (mono_tags, lifting) \t = take i t @ [t ! i] @ take (j - (i + 1)) (drop (i + 1) t) @ [t ! j] @ drop (j + 1) t\ \take (j - (i + 1)) (drop (i + 1) t) = []\ length_append length_list_update list.size(4) self_append_conv2) + moreover have "\k. k < length ((t[i := t ! j])[j := t ! i]) \ (take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) ! k = ((t[i := t ! j])[j := t ! i]) ! k" + proof - + fix k + assume "k < length ((t[i := t ! j])[j := t ! i])" + show "(take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) ! k = ((t[i := t ! j])[j := t ! i]) ! k" + proof (cases "k = i \ k = j") + case True + then show ?thesis + proof (elim disjE) + assume "k = i" + then show ?thesis + by (metis (no_types, lifting) \k < length (t[i := t ! j, j := t ! i])\ append_Cons le_eq_less_or_eq length_list_update length_take min.absorb2 nth_append_length nth_list_update_eq nth_list_update_neq) + next + assume "k = j" + then show ?thesis + by (metis (no_types, lifting) "0.prems"(4) Suc_eq_plus1 \j = i + 1\ \k < length (t[i := t ! j, j := t ! i])\ append.assoc append_Cons le_eq_less_or_eq length_append_singleton length_list_update length_take min.absorb2 nth_append_length nth_list_update postrecording_event) + qed + next + case knij: False + then show ?thesis + proof (cases "k < i") + case True + then show ?thesis + by (metis (no_types, lifting) "0.prems"(2) \j = i + 1\ add_lessD1 length_take less_imp_le_nat min.absorb2 not_less nth_append nth_list_update_neq nth_take) + next + case False + then have "k > j" + using \j = i + 1\ knij by linarith + then have "(take i t @ [t ! j] @ [t ! i] @ drop (j+1) t) ! k = drop (j+1) t ! (k-(j+1))" + proof - + assume a1: "j < k" + have f2: "\n na. ((n::nat) < na) = (n \ na \ n \ na)" + using nat_less_le by blast (* 0.0 ms *) + have f3: "i + 0 = min (length t) i + (0 + 0)" + using "0.prems"(2) \j = i + 1\ by linarith (* 8 ms *) + have f4: "min (length t) i + Suc (0 + 0) = length (take i t) + length [t ! j]" + by force (* 4 ms *) + have f5: "take i t @ [t ! j] @ [] = take i t @ [t ! j]" + by auto (* 0.0 ms *) + have "j = length (take i t @ [t ! j] @ [])" + using f3 by (simp add: \j = i + 1\) (* 4 ms *) + then have "j + 1 = length (take i t @ [t ! j] @ [t ! i])" + by fastforce (* 4 ms *) + then show ?thesis + using f5 f4 f3 f2 a1 by (metis (no_types) One_nat_def \j = i + 1\ add_Suc_right append.assoc length_append less_antisym list.size(3) not_less nth_append) (* 284 ms *) + qed + moreover have "(t[i := t ! j])[j := t ! i] ! k = drop (j+1) ((t[i := t ! j])[j := t ! i]) ! (k-(j+1))" + using "0.prems"(2) \j < k\ by auto + moreover have "drop (j+1) ((t[i := t ! j])[j := t ! i]) = drop (j+1) t" + using "0.prems"(1) by auto + ultimately show ?thesis by simp + qed + qed + qed + ultimately show ?thesis by (simp add: list_eq_iff_nth_eq) + qed + moreover have "\k. k \ j + 1 \ S t k = S ((t[i := t ! j])[j := t ! i]) k" + proof (rule allI, rule impI) + fix k + assume "k \ j + 1" + let ?newt = "((t[i := t ! j])[j := t ! i])" + have "trace init (take k ?newt) (S ?newt k)" + using calculation(1) calculation(2) exists_trace_for_any_i by auto + have "take k ?newt = take (j+1) ?newt @ take (k - (j+1)) (drop (j+1) ?newt)" + by (metis \j + 1 \ k\ le_add_diff_inverse take_add) + have same_traces: "drop (j+1) t = drop (j+1) ?newt" + by (metis "0.prems"(1) Suc_eq_plus1 \j = i + 1\ drop_update_cancel less_SucI less_add_same_cancel1) + have "trace init (take (j+1) ((t[i := t ! j])[j := t ! i])) (S t (j+1))" + by (metis (no_types, lifting) \j = i + 1\ \take (j - 1) t @ [t ! j, t ! i] = (take (j + 1) t)[i := t ! j, j := t ! i]\ add_diff_cancel_right' local.swap s take_update_swap trace_trans) + moreover have "trace init (take (j+1) ?newt) (S ?newt (j+1))" + using \take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\ \trace init (take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t) final\ exists_trace_for_any_i by auto + ultimately have "S ?newt (j+1) = S t (j+1)" + using trace_and_start_determines_end by blast + have "trace (S t (j+1)) (take (k - (j+1)) (drop (j+1) t)) (S t k)" + using "0.prems"(6) \j + 1 \ k\ exists_trace_for_any_i_j by blast + moreover have "trace (S ?newt (j+1)) (take (k - (j+1)) (drop (j+1) ?newt)) (S ?newt k)" + using \j + 1 \ k\ \take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\ \trace init (take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t) final\ exists_trace_for_any_i_j by fastforce + ultimately show "S t k = S ?newt k" + using \S (t[i := t ! j, j := t ! i]) (j + 1) = S t (j + 1)\ same_traces trace_and_start_determines_end by auto + qed + moreover have "\k. k \ i \ S t k = S ((t[i := t ! j])[j := t ! i]) k" + proof (rule allI, rule impI) + fix k + assume "k \ i" + let ?newt = "((t[i := t ! j])[j := t ! i])" + have "trace init (take k t) (S t k)" + using "0.prems"(6) exists_trace_for_any_i by blast + moreover have "trace init (take k ?newt) (S ?newt k)" + using \take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\ \trace init (take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t) final\ exists_trace_for_any_i by auto + moreover have "take k t = take k ?newt" + using "0.prems"(1) \k \ i\ by auto + ultimately show "S t k = S ?newt k" + by (simp add: trace_and_start_determines_end) + qed + moreover have "prerecording_event (swap_events i j t) i" + proof - + have "~ has_snapshotted (S ((t[i := t ! j])[j := t ! i]) i) ?q" + by (metis "0.prems"(6) \j = i + 1\ add.right_neutral calculation(4) le_add1 nsq snapshot_stable_ver_3) + moreover have "regular_event ((t[i := t ! j])[j := t ! i] ! i)" + by (metis "0.prems"(4) "0.prems"(5) \occurs_on (t ! i) \ occurs_on (t ! j)\ nth_list_update_eq nth_list_update_neq postrecording_event prerecording_event) + moreover have "i < length ((t[i := t ! j])[j := t ! i])" + using "0.prems"(1) "0.prems"(2) by auto + ultimately show ?thesis unfolding prerecording_event + by (metis (no_types, hide_lams) "0.prems"(1) \take (j - (i + 1)) (drop (i + 1) t) = []\ \take i t @ [t ! j] @ [t ! i] @ drop (j + 1) t = t[i := t ! j, j := t ! i]\ append_Cons length_list_update nat_less_le nth_list_update_eq nth_list_update_neq self_append_conv2) + qed + moreover have "postrecording_event (swap_events i j t) (i+1)" + proof - + have "has_snapshotted (S ((t[i := t ! j])[j := t ! i]) (i+1)) ?p" + by (metis "0.prems"(4) add.right_neutral calculation(1) calculation(2) calculation(4) le_add1 postrecording_event snapshot_stable_ver_3) + moreover have "regular_event ((t[i := t ! j])[j := t ! i] ! j)" + using "0.prems"(2) "0.prems"(4) length_list_update postrecording_event by auto + moreover have "j < length t" using "0.prems" by auto + ultimately show ?thesis unfolding postrecording_event + by (metis \j = i + 1\ length_list_update nth_list_update_eq swap_neighbors_2) + qed + moreover have "\k. k > i+1 \ k < j+1 \ ~ regular_event ((swap_events i j t) ! k)" using "0" by force + ultimately show ?case using `j = i + 1` by force +next + case (Suc n) + let ?p = "occurs_on (t ! i)" + let ?q = "occurs_on (t ! j)" + let ?t = "take ((j+1) - i) (drop i t)" + let ?subt = "take (j - (i+1)) (drop (i+1) t)" + let ?subt' = "take ((j-1) - (i+1)) (drop (i+1) t)" + have sp: "has_snapshotted (S t i) ?p" + using Suc.prems postrecording_event prerecording_event by blast + have nsq: "~ has_snapshotted (S t j) ?q" + using Suc.prems postrecording_event prerecording_event by blast + have "?p \ ?q" + using Suc.prems computation.post_before_pre_different_processes computation_axioms by blast + have "?subt \ Nil" + using Suc.hyps(2) Suc.prems(1) Suc.prems(2) by auto + have "?subt' = butlast ?subt" + by (metis Suc.prems(2) Suc_eq_plus1 butlast_drop butlast_take drop_take less_imp_le_nat) + have "?t = t ! i # ?subt @ [t ! j]" + proof - + have f1: "Suc j - i = Suc (j - i)" + using Suc.prems(1) Suc_diff_le le_simps(1) by presburger + have f2: "t ! i # drop (Suc i) t = drop i t" + by (meson Cons_nth_drop_Suc Suc.prems(1) Suc.prems(2) less_trans) + have f3: "t ! j # drop (Suc j) t = drop j t" + using Cons_nth_drop_Suc Suc.prems(2) by blast + have f4: "j - (i + 1) + (i + 1) = j" + using Suc.prems(1) by force + have "j - (i + 1) + Suc 0 = j - i" + using Suc.prems(1) Suc_diff_Suc by presburger + then show ?thesis + using f4 f3 f2 f1 by (metis One_nat_def Suc.hyps(2) Suc_eq_plus1 drop_drop take_Suc_Cons take_add take_eq_Nil) + qed + then have "trace (S t i) ?t (S t (j+1))" + by (metis Suc.prems(1) Suc.prems(6) Suc_eq_plus1 exists_trace_for_any_i_j less_SucI nat_less_le) + then have reg_tr_1: "trace (S t i) (t ! i # ?subt) (S t j)" + by (metis (no_types, hide_lams) Suc.hyps(2) Suc.prems(1) Suc.prems(4) Suc.prems(6) Suc_eq_plus1 discrete exists_trace_for_any_i_j postrecording_event step_Suc tr_step) + have reg_st_2: "(S t j) \ (t ! j) \ (S t (j+1))" + using Suc.prems(2) Suc.prems(6) step_Suc by auto + have "?subt = ?subt' @ [t ! (j-1)]" + proof - + have f1: "\n es. \ n < length es \ take n es @ [hd (drop n es)::('a, 'b, 'c) event] = take (Suc n) es" + by (meson take_hd_drop) (* 0.0 ms *) + have f2: "j - 1 - (i + 1) = n" + by (metis (no_types) Suc.hyps(2) Suc_eq_plus1 diff_Suc_1 diff_diff_left plus_1_eq_Suc) (* 28 ms *) + have f3: "\n na. \ n < na \ Suc n \ na" + using Suc_leI by blast (* 0.0 ms *) + then have f4: "Suc i \ j - 1" + by (metis (no_types) Suc.hyps(2) Suc_eq_plus1 diff_diff_left plus_1_eq_Suc zero_less_Suc zero_less_diff) (* 12 ms *) + have f5: "i + 1 < j" + by (metis Suc.hyps(2) zero_less_Suc zero_less_diff) (* 4 ms *) + then have f6: "t ! (j - 1) = hd (drop n (drop (i + 1) t))" + using f4 f3 by (metis (no_types) Suc.hyps(2) Suc.prems(2) Suc_eq_plus1 Suc_lessD add_Suc_right diff_Suc_1 drop_drop hd_drop_conv_nth le_add_diff_inverse2 plus_1_eq_Suc) (* 140 ms *) + have "n < length (drop (i + 1) t)" + using f5 f3 by (metis (no_types) Suc.hyps(2) Suc.prems(2) Suc_eq_plus1 Suc_lessD drop_drop le_add_diff_inverse2 length_drop zero_less_diff) (* 144 ms *) + then show ?thesis + using f6 f2 f1 Suc.hyps(2) by presburger (* 4 ms *) + qed + then have reg_tr: "trace (S t i) (t ! i # ?subt') (S t (j-1))" + proof - + have f1: "j - Suc i = Suc n" + using Suc.hyps(2) by presburger + have f2: "length (take j t) = j" + by (metis (no_types) Suc.prems(2) length_take min.absorb2 nat_le_linear not_less) + have f3: "(t ! i # drop (Suc i) (take j t)) @ [t ! j] = drop i (take (Suc j) t)" + by (metis (no_types) Suc_eq_plus1 \take (j + 1 - i) (drop i t) = t ! i # take (j - (i + 1)) (drop (i + 1) t) @ [t ! j]\ append_Cons drop_take) + have f4: "Suc (i + n) = j - 1" + using f1 by (metis (no_types) Suc.prems(1) Suc_diff_Suc add_Suc_right diff_Suc_1 le_add_diff_inverse nat_le_linear not_less) + have "Suc (j - 1) = j" + using f1 by simp + then have f5: "butlast (take (Suc j) t) = take j t" + using f4 f3 f2 f1 by (metis (no_types) Groups.add_ac(2) One_nat_def append_eq_conv_conj append_take_drop_id butlast_take diff_Suc_1 drop_drop length_append length_drop list.size(3) list.size(4) order_refl plus_1_eq_Suc plus_nat.simps(2) take_add take_all) + have f6: "butlast (take j t) = take (j - 1) t" + by (meson Suc.prems(2) butlast_take nat_le_linear not_less) + have "drop (Suc i) (take j t) \ []" + by (metis (no_types) Nil_is_append_conv Suc_eq_plus1 \take (j - (i + 1)) (drop (i + 1) t) = take (j - 1 - (i + 1)) (drop (i + 1) t) @ [t ! (j - 1)]\ drop_take list.distinct(1)) + then show ?thesis + using f6 f5 f4 f3 by (metis (no_types) Suc.prems(6) Suc_eq_plus1 butlast.simps(2) butlast_drop butlast_snoc drop_take exists_trace_for_any_i_j less_add_Suc1 nat_le_linear not_less) + qed + + have reg_st_1: "(S t (j-1)) \ (t ! (j-1)) \ (S t j)" + by (metis Suc.prems(1) Suc.prems(2) Suc.prems(6) Suc_lessD diff_Suc_1 less_imp_Suc_add step_Suc) + have "~ regular_event (t ! (j-1))" + using Suc.prems(3) \take (j - (i + 1)) (drop (i + 1) t) \ []\ less_diff_conv by auto + moreover have "regular_event (t ! j)" + using Suc.prems(5) computation.prerecording_event computation_axioms by blast + moreover have "can_occur (t ! j) (S t j)" + using happen_implies_can_occur reg_tr_1 reg_st_2 by blast + moreover have njmiq: "occurs_on (t ! (j-1)) \ ?q" + proof (rule ccontr) + assume "~ occurs_on (t ! (j-1)) \ ?q" + then have "occurs_on (t ! (j-1)) = ?q" by simp + then have "has_snapshotted (S t j) ?q" + using Suc.prems(6) calculation(1) diff_le_self nonregular_event_induces_snapshot reg_st_1 snapshot_stable_ver_2 by blast + then show False using nsq by simp + qed + ultimately have "can_occur (t ! j) (S t (j-1))" + using reg_tr reg_st_1 event_can_go_back_if_no_sender by auto + then obtain d where new_st_1: "(S t (j-1)) \ (t ! j) \ d" + using exists_next_if_can_occur by blast + then have "trace (S t i) (t ! i # ?subt' @ [t ! j]) d" using reg_tr trace_snoc by fastforce + moreover have "can_occur (t ! (j-1)) d" + using \(S t (j-1)) \ t ! j \ d\ \occurs_on (t ! (j - 1)) \ occurs_on (t ! j)\ event_stays_valid_if_no_occurrence happen_implies_can_occur reg_st_1 by auto + moreover obtain e where new_st_2: "d \ (t ! (j-1)) \ e" + using calculation(2) exists_next_if_can_occur by blast + + have pre_swap: "e = (S t (j+1))" + proof - + have "states e = states (S t (j+1))" + proof (rule ext) + fix p + have "states (S t (j-1)) p = states (S t j) p" + using no_state_change_if_nonregular_event`~ regular_event (t ! (j-1))` reg_st_1 by auto + moreover have "states d p = states e p" + using no_state_change_if_nonregular_event`~ regular_event (t ! (j-1))` new_st_2 by auto + moreover have "states d p = states (S t (j+1)) p" + proof - + have "\a. states (S t (j + 1)) a = states d a" + by (meson \\ regular_event (t ! (j - 1))\ new_st_1 no_state_change_if_nonregular_event reg_st_1 reg_st_2 same_state_implies_same_result_state) + then show ?thesis + by presburger + qed + ultimately show "states e p = states (S t (j+1)) p" by simp + qed + + moreover have "msgs e = msgs (S t (j+1))" + proof (rule ext) + fix cid + have "isTrans (t ! j) \ isSend (t ! j) \ isRecv (t ! j)" + using \regular_event (t ! j)\ by auto + moreover have "isSnapshot (t ! (j-1)) \ isRecvMarker (t ! (j-1))" + using nonregular_event `~ regular_event (t ! (j-1))` by auto + ultimately show "msgs e cid = msgs (S t (j+1)) cid" + proof (elim disjE, goal_cases) + case 1 + then show ?case + using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_Trans_Snapshot by auto + next + case 2 + then show ?case + using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_msgs_Trans_RecvMarker by auto + next + case 3 + then show ?case + using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_Send_Snapshot by auto + next + case 4 + then show ?case + using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_Recv_Snapshot by auto + next + case 5 + then show ?case + using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_msgs_Send_RecvMarker by auto + next + case 6 + then show ?case + using new_st_1 new_st_2 njmiq reg_st_1 reg_st_2 swap_msgs_Recv_RecvMarker by auto + qed + qed + + moreover have "process_snapshot e = process_snapshot (S t (j+1))" + proof (rule ext) + fix p + have "process_snapshot (S t j) p = process_snapshot (S t (j+1)) p" + using \regular_event (t ! j)\ reg_st_2 regular_event_preserves_process_snapshots by blast + moreover have "process_snapshot (S t (j-1)) p = process_snapshot d p" + using \regular_event (t ! j)\ new_st_1 regular_event_preserves_process_snapshots by blast + moreover have "process_snapshot e p = process_snapshot (S t j) p" + proof - + have "occurs_on (t ! j) = p \ ps e p = ps (S t j) p" + using calculation(2) new_st_2 njmiq no_state_change_if_no_event reg_st_1 by force + then show ?thesis + by (meson new_st_1 new_st_2 no_state_change_if_no_event reg_st_1 same_snapshot_state_implies_same_result_snapshot_state) + qed + ultimately show "process_snapshot e p = process_snapshot (S t (j+1)) p" by simp + qed + + moreover have "cs e = cs (S t (j+1))" + proof (rule ext) + fix cid + have "isTrans (t ! j) \ isSend (t ! j) \ isRecv (t ! j)" + using \regular_event (t ! j)\ by auto + moreover have "isSnapshot (t ! (j-1)) \ isRecvMarker (t ! (j-1))" + using nonregular_event `~ regular_event (t ! (j-1))` by auto + ultimately show "cs e cid = cs (S t (j+1)) cid" + proof (elim disjE, goal_cases) + case 1 + then show ?case + using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Trans_Snapshot by auto + next + case 2 + then show ?case + using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Trans_RecvMarker by auto + next + case 3 + then show ?case + using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Send_Snapshot by auto + next + case 4 + then show ?case + using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Recv_Snapshot njmiq by auto + next + case 5 + then show ?case + using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Send_RecvMarker by auto + next + case 6 + then show ?case + using new_st_1 new_st_2 reg_st_1 reg_st_2 swap_cs_Recv_RecvMarker njmiq by auto + qed + qed + ultimately show ?thesis by auto + qed + + let ?it = "(t[j-1 := t ! j])[j := t ! (j-1)]" + have same_prefix: "take (j-1) ?it = take (j-1) t" by simp + have same_suffix: "drop (j+1) ?it = drop (j+1) t" by simp + have trace_prefix: "trace init (take (j-1) ?it) (S t (j-1))" + using Suc.prems(6) exists_trace_for_any_i by auto + have "?it = take (j-1) t @ [t ! j, t ! (j-1)] @ drop (j+1) t" + proof - + have "1 < j" + by (metis (no_types) Suc.hyps(2) Suc_eq_plus1 add_lessD1 plus_1_eq_Suc zero_less_Suc zero_less_diff) (* 12 ms *) + then have "j - 1 + 1 = j" + by (metis (no_types) le_add_diff_inverse2 nat_less_le) (* 4 ms *) + then show ?thesis + by (metis (no_types) Suc.prems(2) Suc_eq_plus1 add_Suc_right one_add_one swap_neighbors) (* 76 ms *) + qed + have "trace (S t (j-1)) [t ! j, t ! (j-1)] (S t (j+1))" + by (metis new_st_1 new_st_2 pre_swap trace.simps) + have "trace init (take (j+1) t @ drop (j+1) t) final" + by (simp add: Suc.prems(6)) + then have "trace init (take (j+1) t) (S t (j+1)) \ trace (S t (j+1)) (drop (j+1) t) final" + using Suc.prems(6) exists_trace_for_any_i split_trace trace_and_start_determines_end by blast + then have trace_suffix: "trace (S t (j+1)) (drop (j+1) ?it) final" using same_suffix by simp + have "trace init ?it final" + by (metis (no_types, lifting) \t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\ \trace (S t (j + 1)) (drop (j + 1) (t[j - 1 := t ! j, j := t ! (j - 1)])) final\ \trace (S t (j - 1)) [t ! j, t ! (j - 1)] (S t (j + 1))\ \trace init (take (j - 1) (t[j - 1 := t ! j, j := t ! (j - 1)])) (S t (j - 1))\ same_prefix same_suffix trace_trans) + have suffix_same_states: "\k. k > j \ S t k = S ?it k" + proof (rule allI, rule impI) + fix k + assume "k > j" + have eq_trace: "drop (j+1) t = drop (j+1) ?it" by simp + have "trace init (take (j+1) ?it) (S ?it (j+1))" + using \trace init (t[j - 1 := t ! j, j := t ! (j - 1)]) final\ exists_trace_for_any_i by blast + moreover have "trace init (take (j+1) ?it) (S t (j+1))" + proof - + have f1: "\es esa esb esc. (esb::('a, 'b, 'c) event list) @ es \ esa @ esc @ es \ esa @ esc = esb" + by auto + have f2: "take (j + 1) (t[j - 1 := t ! j, j := t ! (j - 1)]) @ drop (j + 1) t = t [j - 1 := t ! j, j := t ! (j - 1)]" + by (metis append_take_drop_id same_suffix) + have "trace init (take (j - 1) t @ [t ! j, t ! (j - 1)]) (S t (j + 1))" + using \trace (S t (j - 1)) [t ! j, t ! (j - 1)] (S t (j + 1))\ same_prefix trace_prefix trace_trans by presburger + then show ?thesis + using f2 f1 by (metis (no_types) \t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\) + qed + ultimately have eq_start: "S ?it (j+1) = S t (j+1)" + using trace_and_start_determines_end by blast + then have "take k ?it = take (j+1) ?it @ take (k - (j+1)) (drop (j+1) ?it)" + by (metis Suc_eq_plus1 Suc_leI \j < k\ le_add_diff_inverse take_add) + have "trace (S ?it (j+1)) (take (k - (j+1)) (drop (j+1) ?it)) (S ?it k)" + by (metis Suc_eq_plus1 Suc_leI \j < k\ \trace init (t[j - 1 := t ! j, j := t ! (j - 1)]) final\ exists_trace_for_any_i_j) + moreover have "trace (S t (j+1)) (take (k - (j+1)) (drop (j+1) t)) (S t k)" + using Suc.prems(6) \j < k\ exists_trace_for_any_i_j by fastforce + ultimately show "S t k = S ?it k" + using eq_start trace_and_start_determines_end by auto + qed + have prefix_same_states: "\k. k < j \ S t k = S ?it k" + proof (rule allI, rule impI) + fix k + assume "k < j" + have "trace init (take k t) (S t k)" + using Suc.prems(6) exists_trace_for_any_i by blast + moreover have "trace init (take k ?it) (S ?it k)" + by (meson \trace init (t[j - 1 := t ! j, j := t ! (j - 1)]) final\ exists_trace_for_any_i) + ultimately show "S t k = S ?it k" + using \k < j\ s_def by auto + qed + moreover have "j - 1 < length ?it" + using Suc.prems(2) by auto + moreover have "prerecording_event ?it (j-1)" + proof - + have f1: "t[j - 1 := t ! j, j := t ! (j - 1)] ! (j - 1) = t[j - 1 := t ! j] ! (j - 1)" + by (metis (no_types) njmiq nth_list_update_neq) (* 28 ms *) + have "j \ 0" + by (metis (no_types) Suc.prems(1) not_less_zero) (* 0.0 ms *) + then have "\ j < 1" + by blast (* 0.0 ms *) + then have "S t (j - 1) = S (t[j - 1 := t ! j, j := t ! (j - 1)]) (j - 1)" + by (simp add: prefix_same_states) (* 8 ms *) + then show ?thesis + using f1 by (metis \regular_event (t ! j)\ calculation(4) computation.prerecording_event computation_axioms length_list_update njmiq no_state_change_if_no_event nsq nth_list_update_eq reg_st_1) (* 456 ms *) + qed + moreover have "postrecording_event ?it i" + proof - + have "i < length ?it" + using Suc.prems(4) postrecording_event by auto + then show ?thesis + proof - + assume "i < length (t[j - 1 := t ! j, j := t ! (j - 1)])" + have "i < j - 1" + by (metis (no_types) Suc.hyps(2) cancel_ab_semigroup_add_class.diff_right_commute diff_diff_left zero_less_Suc zero_less_diff) + then show ?thesis + using Suc.prems(1) Suc.prems(4) postrecording_event prefix_same_states by auto + qed + qed + moreover have "i < j - 1" + using Suc.hyps(2) by auto + moreover have "\k. i < k \ k < (j-1) \ ~ regular_event (?it ! k)" + proof (rule allI, rule impI) + fix k + assume "i < k \ k < (j-1)" + show "~ regular_event (?it ! k)" + using Suc.prems(3) \i < k \ k < j - 1\ by force + qed + moreover have "(j-1) - (i+1) = n" using Suc.prems Suc.hyps by auto + ultimately have ind: "trace init (swap_events i (j-1) ?it) final + \ (\k. k \ (j-1)+1 \ S (swap_events i (j-1) ?it) k = S ?it k) + \ (\k. k \ i \ S (swap_events i (j-1) ?it) k = S ?it k) + \ prerecording_event (swap_events i (j-1) ?it) i + \ postrecording_event (swap_events i (j-1) ?it) (i+1) + \ (\k. k > i+1 \ k < (j-1)+1 \ ~ regular_event ((swap_events i (j-1) ?it) ! k))" + using Suc.hyps \trace init ?it final\ by blast + then have new_trace: "trace init (swap_events i (j-1) ?it) final" by blast + have equal_suffix_states: "\k. k \ j \ S (swap_events i (j-1) ?it) k = S ?it k" + using Suc.prems(1) ind by simp + have equal_prefix_states: "\k. k \ i \ S (swap_events i (j-1) ?it) k = S ?it k" + using ind by blast + have neighboring_events_shifted: "\k. k > i+1 \ k < j \ ~ regular_event ((swap_events i (j-1) ?it) ! k)" + using ind by force + + let ?itn = "swap_events i (j-1) ?it" + have "?itn = swap_events i j t" + proof - + have f1: "i \ j - 1" + using \i < j - 1\ less_imp_le_nat by blast + have "t ! j # [t ! (j - 1)] @ drop (j + 1) t = drop (j - 1) (take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t)" + using \t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\ same_prefix by force + then have f2: "t[j - 1 := t ! j, j := t ! (j - 1)] ! (j - 1) = t ! j \ drop (j - 1 + 1) (t[j - 1 := t ! j, j := t ! (j - 1)]) = t ! (j - 1) # [] @ drop (j + 1) t" + by (metis (no_types) Cons_nth_drop_Suc Suc_eq_plus1 \j - 1 < length (t[j - 1 := t ! j, j := t ! (j - 1)])\ \t[j - 1 := t ! j, j := t ! (j - 1)] = take (j - 1) t @ [t ! j, t ! (j - 1)] @ drop (j + 1) t\ append_Cons list.inject) + have "t ! i = t[j - 1 := t ! j, j := t ! (j - 1)] ! i" + by (metis (no_types) Suc.prems(1) \i < j - 1\ nat_neq_iff nth_list_update_neq) + then show ?thesis + using f2 f1 by (metis (no_types) Suc.prems(1) \take (j - (i + 1)) (drop (i + 1) t) = take (j - 1 - (i + 1)) (drop (i + 1) t) @ [t ! (j - 1)]\ append.assoc append_Cons drop_take less_imp_le_nat same_prefix take_update_cancel) + qed + + moreover have "\k. k \ i \ S t k = S ?itn k" + using Suc.prems(1) equal_prefix_states prefix_same_states by auto + moreover have "\k. k \ j + 1 \ S t k = S ?itn k" + by (metis (no_types, lifting) Suc_eq_plus1 add_lessD1 equal_suffix_states lessI nat_less_le suffix_same_states) + moreover have "\k. k > i+1 \ k < j+1 \ ~ regular_event (?itn ! k)" + proof - + have "~ regular_event (?itn ! j)" + proof - + have f1: "j - 1 < length t" + using \j - 1 < length (t[j - 1 := t ! j, j := t ! (j - 1)])\ by force + have f2: "\n na es. \ n < na \ \ na < length es \ drop (Suc na) (take n es @ [hd (drop na es), es ! n::('a, 'b, 'c) event] @ take (na - Suc n) (drop (Suc n) es) @ drop (Suc na) es) = drop (Suc na) es" + by (metis Suc_eq_plus1 hd_drop_conv_nth swap_identical_tails) + have f3: "t ! j = hd (drop j t)" + by (simp add: Suc.prems(2) hd_drop_conv_nth) + have "\ j < 1" + using Suc.prems(1) by blast + then have "\ regular_event (hd (drop j (take i (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)]) @ [hd (drop (j - 1) (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)])), t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)] ! i] @ take (j - 1 - Suc i) (drop (Suc i) (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)])) @ drop (Suc (j - 1)) (t[j - 1 := hd (drop j t), j := hd (drop (j - 1) t)]))))" + using f2 f1 by (metis (no_types) Suc.prems(2) \\ regular_event (t ! (j - 1))\ \i < j - 1\ add_diff_inverse_nat hd_drop_conv_nth length_list_update nth_list_update_eq plus_1_eq_Suc) + then show ?thesis + using f3 f1 by (metis Suc.prems(2) Suc_eq_plus1 \i < j - 1\ hd_drop_conv_nth length_list_update swap_identical_length) + qed + then show ?thesis + by (metis Suc_eq_plus1 less_Suc_eq neighboring_events_shifted) + qed + + ultimately show ?case using ind by presburger +qed + +subsubsection \Relating configurations and the computed snapshot\ + +definition ps_equal_to_snapshot where + "ps_equal_to_snapshot c c' \ + \p. Some (states c p) = process_snapshot c' p" + +definition cs_equal_to_snapshot where + "cs_equal_to_snapshot c c' \ + \cid. channel cid \ None + \ filter ((\) Marker) (msgs c cid) + = map Msg (fst (channel_snapshot c' cid))" + +definition state_equal_to_snapshot where + "state_equal_to_snapshot c c' \ + ps_equal_to_snapshot c c' \ cs_equal_to_snapshot c c'" + +lemma init_is_s_t_0: + assumes + "trace init t final" + shows + "init = (S t 0)" + by (metis assms exists_trace_for_any_i take_eq_Nil tr_init trace_and_start_determines_end) + +lemma final_is_s_t_len_t: + assumes + "trace init t final" + shows + "final = S t (length t)" + by (metis assms exists_trace_for_any_i order_refl take_all trace_and_start_determines_end) + +lemma snapshot_event: + assumes + "trace init t final" and + "~ has_snapshotted (S t i) p" and + "has_snapshotted (S t (i+1)) p" + shows + "isSnapshot (t ! i) \ isRecvMarker (t ! i)" +proof - + have "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis Suc_eq_plus1 assms(1) assms(2) assms(3) distributed_system.step_Suc computation_axioms computation_def nat_less_le not_less not_less_eq s_def take_all) + then show ?thesis + using assms(2) assms(3) nonregular_event regular_event_cannot_induce_snapshot by blast +qed + +lemma snapshot_state: + assumes + "trace init t final" and + "states (S t i) p = u" and + "~ has_snapshotted (S t i) p" and + "has_snapshotted (S t (i+1)) p" + shows + "ps (S t (i+1)) p = Some u" +proof - + have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis add.commute assms(1) assms(3) assms(4) le_SucI le_eq_less_or_eq le_refl nat_neq_iff no_change_if_ge_length_t plus_1_eq_Suc step_Suc) + let ?q = "occurs_on (t ! i)" + have qp: "?q = p" + proof (rule ccontr) + assume "?q \ p" + then have "has_snapshotted (S t (i+1)) p = has_snapshotted (S t i) p" + using local.step no_state_change_if_no_event by auto + then show False using assms by simp + qed + have "isSnapshot (t ! i) \ isRecvMarker (t ! i)" using assms snapshot_event by auto + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then have "t ! i = Snapshot p" + by (metis event.collapse(4) qp) + then show ?thesis + using assms(2) local.step by auto + next + case 2 + then obtain cid' q where "t ! i = RecvMarker cid' p q" + by (metis event.collapse(5) qp) + then show ?thesis using assms step by auto + qed +qed + +lemma snapshot_state_unchanged_trace_2: + shows + "\ trace init t final; i \ j; j \ length t; + ps (S t i) p = Some u + \ \ ps (S t j) p = Some u" +proof (induct i j rule:S_induct) + case S_init + then show ?case by simp +next + case S_step + then show ?case using snapshot_state_unchanged by auto +qed + +lemma no_recording_cs_if_not_snapshotted: + shows + "\ trace init t final; ~ has_snapshotted (S t i) p; + channel cid = Some (q, p) \ \ cs (S t i) cid = cs init cid" +proof (induct i) + case 0 + then show ?case + by (metis exists_trace_for_any_i list.discI take_eq_Nil trace.simps) +next + case (Suc i) + have "Suc i < length t" + proof - + have "has_snapshotted final p" + using all_processes_snapshotted_in_final_state valid by blast + show ?thesis + proof (rule ccontr) + assume "~ Suc i < length t" + then have "Suc i \ length t" by simp + then have "has_snapshotted (S t (Suc i)) p" + using Suc.prems(1) \ps final p \ None\ final_is_s_t_len_t snapshot_stable_ver_3 by blast + then show False using Suc by simp + qed + qed + + then have t_dec: "trace init (take i t) (S t i) \ (S t i) \ (t ! i) \ (S t (Suc i))" + using Suc.prems(1) exists_trace_for_any_i step_Suc by auto + moreover have step: "(S t i) \ (t ! i) \ (S t (Suc i))" using calculation by simp + + ultimately have IH: "cs (S t i) cid = cs init cid" + using Suc.hyps Suc.prems(1) Suc.prems(2) Suc.prems(3) snapshot_state_unchanged by fastforce + + then show ?case + proof (cases "t ! i") + case (Snapshot r) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + then have "r = p" by simp + then have "has_snapshotted (S t (Suc i)) p" + using Snapshot step by auto + then show False using Suc by simp + qed + then have "cs (S t i) cid = cs (S t (Suc i)) cid" + using Snapshot Suc.prems(3) local.step by auto + then show ?thesis using IH by simp + next + case (RecvMarker cid' r s) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + then have "r = p" by simp + then have "has_snapshotted (S t (Suc i)) p" + using RecvMarker t_dec recv_marker_means_snapshotted_1 by blast + then show False using Suc by simp + qed + have "cid' \ cid" + proof (rule ccontr) + assume "~ cid' \ cid" + then have "channel cid' = Some (s, r)" using t_dec can_occur_def RecvMarker by simp + then show False + using Suc.prems(3) \\ cid' \ cid\ \r \ p\ by auto + qed + then have "cs (S t i) cid = cs (S t (Suc i)) cid" + proof - + have "\s. channel cid = Some (s, r)" using `r \ p` Suc by simp + with RecvMarker t_dec `cid' \ cid` `r \ p` Suc.prems(3) show ?thesis + by (cases "has_snapshotted (S t i) r", auto) + qed + then show ?thesis using IH by simp + next + case (Trans r u u') + then show ?thesis + using IH t_dec by auto + next + case (Send cid' r s u u' m) + then show ?thesis + using IH local.step by auto + next + case (Recv cid' r s u u' m) + then have "snd (cs (S t i) cid) = NotStarted" + by (simp add: IH no_initial_channel_snapshot) + with Recv step Suc show ?thesis by (cases "cid' = cid", auto) + qed +qed + +lemma cs_done_implies_has_snapshotted: + assumes + "trace init t final" and + "snd (cs (S t i) cid) = Done" and + "channel cid = Some (p, q)" + shows + "has_snapshotted (S t i) q" +proof - + show ?thesis + using assms no_initial_channel_snapshot no_recording_cs_if_not_snapshotted by fastforce +qed + +lemma exactly_one_snapshot: + assumes + "trace init t final" + shows + "\!i. ~ has_snapshotted (S t i) p \ has_snapshotted (S t (i+1)) p" (is ?P) +proof - + have "~ has_snapshotted init p" + using no_initial_process_snapshot by auto + moreover have "has_snapshotted final p" + using all_processes_snapshotted_in_final_state valid by blast + moreover have "trace (S t 0) t (S t (length t))" + using assms final_is_s_t_len_t init_is_s_t_0 by auto + ultimately have ex_snap: "\i. ~ has_snapshotted (S t i) p \ has_snapshotted (S t (i+1)) p" + using assms exists_snapshot_for_all_p by auto + show ?thesis + proof (rule ccontr) + assume "~ ?P" + then have "\i j. (i \ j) \ ~ has_snapshotted (S t i) p \ has_snapshotted (S t (i+1)) p \ + ~ has_snapshotted (S t j) p \ has_snapshotted (S t (j+1)) p" + using ex_snap by blast + then have "\i j. (i < j) \ ~ has_snapshotted (S t i) p \ has_snapshotted (S t (i+1)) p \ + ~ has_snapshotted (S t j) p \ has_snapshotted (S t (j+1)) p" + by (meson linorder_neqE_nat) + then obtain i j where "i < j" "~ has_snapshotted (S t i) p" "has_snapshotted (S t (i+1)) p" + "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" + by blast + have "trace (S t (i+1)) (take (j - (i+1)) (drop (i+1) t)) (S t j)" + using \i < j\ assms exists_trace_for_any_i_j by fastforce + then have "has_snapshotted (S t j) p" + using \ps (S t (i + 1)) p \ None\ snapshot_stable by blast + then show False using `~ has_snapshotted (S t j) p` by simp + qed +qed + +lemma initial_cs_changes_implies_nonregular_event: + assumes + "trace init t final" and + "snd (cs (S t i) cid) = NotStarted" and + "snd (cs (S t (i+1)) cid) \ NotStarted" and + "channel cid = Some (p, q)" + shows + "~ regular_event (t ! i)" +proof - + have "i < length t" + proof (rule ccontr) + assume "~ i < length t" + then have "S t i = S t (i+1)" + using assms(1) no_change_if_ge_length_t by auto + then show False using assms by presburger + qed + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + using assms(1) step_Suc by auto + show ?thesis + proof (rule ccontr) + assume "~ ~ regular_event (t ! i)" + then have "regular_event (t ! i)" by simp + then have "cs (S t i) cid = cs (S t (i+1)) cid" + proof (cases "isRecv (t ! i)") + case False + then show ?thesis + using \regular_event (t ! i)\ local.step no_cs_change_if_no_event by blast + next + case True + then obtain cid' r s u u' m where Recv: "t ! i = Recv cid' r s u u' m" by (meson isRecv_def) + with assms step show ?thesis + proof (cases "cid = cid'") + case True + then show ?thesis using assms step Recv by simp + next + case False + then show ?thesis using assms step Recv by simp + qed + qed + then show False using assms by simp + qed +qed + +lemma cs_in_initial_state_implies_not_snapshotted: + assumes + "trace init t final" and + "snd (cs (S t i) cid) = NotStarted" and + "channel cid = Some (p, q)" + shows + "~ has_snapshotted (S t i) q" +proof (rule ccontr) + assume "~ ~ has_snapshotted (S t i) q" + then obtain j where "j < i" "~ has_snapshotted (S t j) q" "has_snapshotted (S t (j+1)) q" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p computation.snapshot_stable_ver_3 computation_axioms nat_le_linear order_le_less) + have step_j: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis \\ \ ps (S t i) q \ None\ \\ ps (S t j) q \ None\ \j < i\ add.commute assms(1) linorder_neqE_nat no_change_if_ge_length_t order_le_less order_refl plus_1_eq_Suc step_Suc) + have tr_j_i: "trace (S t (j+1)) (take (i - (j+1)) (drop (j+1) t)) (S t i)" + using \j < i\ assms(1) exists_trace_for_any_i_j by fastforce + have "~ regular_event (t ! j)" + using step_j \\ ps (S t j) q \ None\ \ps (S t (j + 1)) q \ None\ regular_event_cannot_induce_snapshot by blast + then have "isSnapshot (t ! j) \ isRecvMarker (t ! j)" + using nonregular_event by auto + then have "snd (cs (S t (j+1)) cid) \ NotStarted" + proof (elim disjE, goal_cases) + case 1 + have "occurs_on (t ! j) = q" + using \\ ps (S t j) q \ None\ \ps (S t (j + 1)) q \ None\ distributed_system.no_state_change_if_no_event distributed_system_axioms step_j by fastforce + with 1 have "t ! j = Snapshot q" using isSnapshot_def by auto + then show ?thesis using step_j assms by simp + next + case 2 + have "occurs_on (t ! j) = q" + using \\ ps (S t j) q \ None\ \ps (S t (j + 1)) q \ None\ distributed_system.no_state_change_if_no_event distributed_system_axioms step_j by fastforce + with 2 obtain cid' s where RecvMarker: "t ! j = RecvMarker cid' q s" + by (metis event.collapse(5)) + then show ?thesis + proof (cases "cid' = cid") + case True + then show ?thesis using RecvMarker step_j assms by simp + next + case False + have "~ has_snapshotted (S t j) q" + using \\ ps (S t j) q \ None\ by auto + moreover have "\r. channel cid = Some (r, q)" + by (simp add: assms(3)) + ultimately show ?thesis using RecvMarker step_j assms False by simp + qed + qed + then have "snd (cs (S t i) cid) \ NotStarted" + using tr_j_i cs_not_not_started_stable_trace assms by blast + then show False using assms by simp +qed + +lemma nonregular_event_in_initial_state_implies_cs_changed: + assumes + "trace init t final" and + "snd (cs (S t i) cid) = NotStarted" and + "~ regular_event (t ! i)" and + "occurs_on (t ! i) = q" and + "channel cid = Some (p, q)" and + "i < length t" + shows + "snd (cs (S t (i+1)) cid) \ NotStarted" +proof - + have step: "(S t i) \ (t ! i) \ (S t (i+1))" using step_Suc assms by auto + have "isSnapshot (t ! i) \ isRecvMarker (t ! i)" + using assms(3) nonregular_event by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then show ?thesis + using assms cs_in_initial_state_implies_not_snapshotted local.step nonregular_event_induces_snapshot by blast + next + case 2 + then show ?thesis + by (metis assms(1) assms(2) assms(3) assms(4) assms(5) cs_in_initial_state_implies_not_snapshotted local.step nonregular_event_induces_snapshot) + qed +qed + +lemma cs_recording_implies_snapshot: + assumes + "trace init t final" and + "snd (cs (S t i) cid) = Recording" and + "channel cid = Some (p, q)" + shows + "has_snapshotted (S t i) q" +proof (rule ccontr) + assume "~ has_snapshotted (S t i) q" + have "\ trace init t final; ~ has_snapshotted (S t i) p; channel cid = Some (p, q) \ + \ snd (cs (S t i) cid) = NotStarted" + proof (induct i) + case 0 + then show ?case + using init_is_s_t_0 no_initial_channel_snapshot by auto + next + case (Suc n) + have step: "(S t n) \ (t ! n) \ (S t (n+1))" + by (metis Suc.prems(2) Suc_eq_plus1 all_processes_snapshotted_in_final_state assms(1) distributed_system.step_Suc distributed_system_axioms final_is_s_t_len_t le_add1 not_less snapshot_stable_ver_3) + have "snd (cs (S t n) cid) = NotStarted" + using Suc.hyps Suc.prems(2) assms snapshot_state_unchanged computation_axioms local.step by fastforce + then show ?case + by (metis Suc.prems(1) \\ ps (S t i) q \ None\ assms(2) assms(3) cs_not_not_started_stable_trace exists_trace_for_any_i no_recording_cs_if_not_snapshotted recording_state.simps(2)) + qed + then show False + using \\ ps (S t i) q \ None\ assms computation.no_initial_channel_snapshot computation_axioms no_recording_cs_if_not_snapshotted by fastforce +qed + +lemma cs_done_implies_both_snapshotted: + assumes + "trace init t final" and + "snd (cs (S t i) cid) = Done" and + "i < length t" and + "channel cid = Some (p, q)" + shows + "has_snapshotted (S t i) p" + "has_snapshotted (S t i) q" +proof - + have "trace init (take i t) (S t i)" + using assms(1) exists_trace_for_any_i by blast + then have "RecvMarker cid q p : set (take i t)" + by (metis assms(1,2,4) cs_done_implies_has_snapshotted done_only_from_recv_marker_trace computation.no_initial_process_snapshot computation_axioms init_is_s_t_0 list.discI trace.simps) + then obtain k where "t ! k = RecvMarker cid q p" "0 \ k" "k < i" + by (metis add.right_neutral add_diff_cancel_right' append_Nil append_take_drop_id assms(1) exists_index take0) + then have "has_snapshotted (S t (k+1)) q" + by (metis (no_types, lifting) Suc_eq_plus1 Suc_leI assms(1,2,4) computation.cs_done_implies_has_snapshotted computation.no_change_if_ge_length_t computation_axioms less_le not_less_eq recv_marker_means_cs_Done) + then show "has_snapshotted (S t i) q" + using assms cs_done_implies_has_snapshotted by blast + have step_k: "(S t k) \ (t ! k) \ (S t (k+1))" + by (metis Suc_eq_plus1 \k < i\ add_lessD1 assms(1) assms(3) distributed_system.step_Suc distributed_system_axioms less_imp_add_positive) + then have "Marker : set (msgs (S t k) cid)" + proof - + have "can_occur (t ! k) (S t k)" using happen_implies_can_occur step_k by blast + then show ?thesis unfolding can_occur_def `t ! k = RecvMarker cid q p` + using hd_in_set by fastforce + qed + then have "has_snapshotted (S t k) p" + using assms(1,4) no_marker_if_no_snapshot by blast + then show "has_snapshotted (S t i) p" + using \k < i\ assms(1) less_imp_le_nat snapshot_stable_ver_3 by blast +qed + +lemma cs_done_implies_same_snapshots: + assumes "trace init t final" "i \ j" "j \ length t" + shows "snd (cs (S t i) cid) = Done \ channel cid = Some (p, q) \ cs (S t i) cid = cs (S t j) cid" +using assms proof (induct i j rule: S_induct) + case (S_init i) + then show ?case by auto +next + case (S_step i j) + have snap_p: "has_snapshotted (S t i) p" + using S_step.hyps(1) S_step.hyps(2) S_step.prems(1,2) assms(1) cs_done_implies_both_snapshotted(1) by auto + have snap_q: "has_snapshotted (S t i) q" + using S_step.prems(1,2) assms(1) cs_done_implies_has_snapshotted by blast + from S_step have "cs (S t i) cid = cs (S t (Suc i)) cid" + proof (cases "t ! i") + case (Snapshot r) + from Snapshot S_step.hyps(3) snap_p have False if "r = p" using that by (auto simp: can_occur_def) + moreover + from Snapshot S_step.hyps(3) snap_q have False if "r = q" using that by (auto simp: can_occur_def) + ultimately show ?thesis using Snapshot S_step by force + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "has_snapshotted (S t i) r") + case True + with RecvMarker S_step show ?thesis + proof (cases "cid = cid'") + case True + then have "cs (S t (Suc i)) cid = (fst (cs (S t i) cid), Done)" + using RecvMarker S_step by simp + then show ?thesis + by (metis S_step.prems(1) prod.collapse) + qed auto + next + case no_snap: False + then show ?thesis + proof (cases "cid = cid'") + case True + then have "cs (S t (Suc i)) cid = (fst (cs (S t i) cid), Done)" + using RecvMarker S_step by simp + then show ?thesis + by (metis S_step.prems(1) prod.collapse) + next + case False + then have "r \ p" using no_snap snap_p by auto + moreover have "\s. channel cid = Some (s, r)" + using S_step(5) assms(1) cs_done_implies_has_snapshotted no_snap by blast + ultimately show ?thesis using RecvMarker S_step False no_snap by simp + qed + qed + next + case (Recv cid' r s u u' m) + with S_step show ?thesis by (cases "cid = cid'", auto) + qed auto + with S_step show ?case by auto +qed + +lemma snapshotted_and_not_done_implies_marker_in_channel: + assumes + "trace init t final" and + "has_snapshotted (S t i) p" and + "snd (cs (S t i) cid) \ Done" and + "i \ length t" and + "channel cid = Some (p, q)" + shows + "Marker : set (msgs (S t i) cid)" +proof - + obtain j where jj: "j < i" "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" + by (metis Suc_eq_plus1 assms(1) assms(2) exists_snapshot_for_all_p computation.snapshot_stable_ver_2 computation_axioms le_eq_less_or_eq nat_neq_iff) + have step: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis \\ ps (S t j) p \ None\ \j < i\ add.commute assms(1) assms(2) linorder_neqE_nat no_change_if_ge_length_t order_le_less order_refl plus_1_eq_Suc step_Suc) + then have "Marker : set (msgs (S t (j+1)) cid)" + proof - + have "~ regular_event (t ! j)" + by (meson \\ ps (S t j) p \ None\ \ps (S t (j + 1)) p \ None\ distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms local.step) + then have "isSnapshot (t ! j) \ isRecvMarker (t ! j)" using nonregular_event by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then obtain r where Snapshot: "t ! j = Snapshot r" by (meson isSnapshot_def) + then have "r = p" + using jj(2) jj(3) local.step by auto + then show ?thesis using Snapshot assms step by simp + next + case 2 + then obtain cid' s where RecvMarker: "t ! j = RecvMarker cid' p s" + by (metis jj(2,3) distributed_system.no_state_change_if_no_event distributed_system_axioms event.sel(5) isRecvMarker_def local.step) + moreover have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "snd (cs (S t (j+1)) cid) = Done" using RecvMarker step by simp + then have "snd (cs (S t i) cid) = Done" + proof - + assume a1: "snd (cs (S t (j + 1)) cid) = Done" + have f2: "ps (S t j) p = None" + using jj(2) by blast + have "j < length t" + using assms(4) jj(1) by linarith + then have "t ! j = RecvMarker cid q p" + using f2 a1 assms(1) assms(5) cs_done_implies_both_snapshotted(1) done_only_from_recv_marker local.step by blast + then show ?thesis + using f2 by (metis (no_types) Suc_eq_plus1 assms(1) local.step recv_marker_means_snapshotted) + qed + then show False using assms by simp + qed + ultimately show ?thesis using jj assms step by auto + qed + qed + show ?thesis + proof (rule ccontr) + let ?t = "take (i - (j+1)) (drop (j+1) t)" + have tr_j: "trace (S t (j+1)) ?t (S t i)" + by (metis \j < i\ assms(1) discrete exists_trace_for_any_i_j) + assume "~ Marker : set (msgs (S t i) cid)" + then obtain ev where "ev \ set ?t" "\p q. ev = RecvMarker cid p q" + using \Marker \ set (msgs (S t (j + 1)) cid)\ marker_must_be_delivered_2_trace tr_j assms by blast + obtain k where "t ! k = ev" "j < k" "k < i" + using \ev \ set (take (i - (j + 1)) (drop (j + 1) t))\ assms(1) exists_index by fastforce + have step_k: "(S t k) \ (t ! k) \ (S t (k+1))" + proof - + have "k < length t" + using \k < i\ assms(4) by auto + then show ?thesis using step_Suc assms by simp + qed + have "ev = RecvMarker cid q p" using assms step_k can_occur_def + using \\p q. ev = RecvMarker cid p q\ \t ! k = ev\ by auto + then have "snd (cs (S t (k+1)) cid) = Done" + using \k < i\ \t ! k = ev\ assms(1) assms(4) recv_marker_means_cs_Done by auto + moreover have "trace (S t (k+1)) (take (i - (k+1)) (drop (k+1) t)) (S t i)" + by (meson \k < i\ assms(1) discrete exists_trace_for_any_i_j) + ultimately have "snd (cs (S t i) cid) = Done" + by (metis \k < i\ assms(1) assms(4) assms(5) cs_done_implies_same_snapshots discrete) + then show False using assms by simp + qed +qed + +lemma no_marker_left_in_final_state: + assumes + "trace init t final" + shows + "Marker \ set (msgs final cid)" (is ?P) +proof (rule ccontr) + assume "~ ?P" + then obtain i where "i > length t" "Marker \ set (msgs (S t i) cid)" using assms l1 + by (metis final_is_s_t_len_t le_neq_implies_less) + then have "S t (length t) \ S t i" + proof - + have "msgs (S t i) cid \ msgs final cid" + using \Marker \ set (msgs (S t i) cid)\ `~ ?P` by auto + then show ?thesis using final_is_s_t_len_t assms by auto + qed + moreover have "S t (length t) = S t i" + using assms `i > length t` less_imp_le no_change_if_ge_length_t by simp + ultimately show False by simp +qed + +lemma all_channels_done_in_final_state: + assumes + "trace init t final" and + "channel cid = Some (p, q)" + shows + "snd (cs final cid) = Done" +proof (rule ccontr) + assume cs_not_done: "~ snd (cs final cid) = Done" + obtain i where snap_p: "~ has_snapshotted (S t i) p" "has_snapshotted (S t (i+1)) p" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) + have "i < length t" + proof - + have "S t i \ S t (i+1)" using snap_p by auto + then show ?thesis + by (meson assms(1) computation.no_change_if_ge_length_t computation_axioms le_add1 not_less) + qed + let ?t = "take (length t - (i+1)) (drop (i+1) t)" + have tr: "trace (S t (i+1)) ?t (S t (length t))" + by (meson \i < length t\ assms(1) discrete exists_trace_for_any_i_j) + have "Marker \ set (msgs (S t (i+1)) cid)" + proof - + have n_done: "snd (cs (S t (i+1)) cid) \ Done" + proof (rule ccontr) + assume "~ snd (cs (S t (i+1)) cid) \ Done" + then have "snd (cs final cid) = Done" + by (metis Suc_eq_plus1 Suc_leI \i < length t\ assms final_is_s_t_len_t computation.cs_done_implies_same_snapshots computation_axioms order_refl) + then show False using cs_not_done by simp + qed + then show ?thesis using snapshotted_and_not_done_implies_marker_in_channel snap_p assms + proof - + have "i+1 \ length t" using `i < length t` by auto + then show ?thesis + using snapshotted_and_not_done_implies_marker_in_channel snap_p assms n_done by simp + qed + qed + moreover have "Marker \ set (msgs (S t (length t)) cid)" using final_is_s_t_len_t no_marker_left_in_final_state assms by blast + ultimately have rm_prov: "\ev \ set ?t. (\q p. ev = RecvMarker cid q p)" using tr message_must_be_delivered_2_trace assms + by (simp add: marker_must_be_delivered_2_trace) + then obtain k where "\q p. t ! k = RecvMarker cid q p" "i+1 \ k" "k < length t" + by (metis assms(1) exists_index) + then have step: "(S t k) \ (t ! k) \ (S t (k+1))" + by (metis Suc_eq_plus1_left add.commute assms(1) step_Suc) + then have RecvMarker: "t ! k = RecvMarker cid q p" + by (metis RecvMarker_given_channel \\q p. t ! k = RecvMarker cid q p\ assms(2) event.disc(25) event.sel(10) happen_implies_can_occur) + then have "snd (cs (S t (k+1)) cid) = Done" + using step \k < length t\ assms(1) recv_marker_means_cs_Done by blast + then have "snd (cs final cid) = Done" + using \Marker \ set (msgs (S t (length t)) cid)\ all_processes_snapshotted_in_final_state assms(1) assms(2) final_is_s_t_len_t snapshotted_and_not_done_implies_marker_in_channel by fastforce + then show False using cs_not_done by simp +qed + +lemma cs_NotStarted_implies_empty_cs: + shows + "\ trace init t final; channel cid = Some (p, q); i < length t; ~ has_snapshotted (S t i) q \ + \ cs (S t i) cid = ([], NotStarted)" + by (simp add: no_initial_channel_snapshot no_recording_cs_if_not_snapshotted) + +lemma fst_changed_by_recv_recording_trace: + assumes + "i < j" and + "j \ length t" and + "trace init t final" and + "fst (cs (S t i) cid) \ fst (cs (S t j) cid)" and + "channel cid = Some (p, q)" + shows + "\k. i \ k \ k < j \ (\p q u u' m. t ! k = Recv cid q p u u' m) \ (snd (cs (S t k) cid) = Recording)" (is ?P) +proof (rule ccontr) + assume "~ ?P" + have "\ i < j; j \ length t; ~ ?P; trace init t final; channel cid = Some (p, q) \ \ fst (cs (S t i) cid) = fst (cs (S t j) cid)" + proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by linarith + next + case (Suc n) + then have step: "(S t i) \ t ! i \ (S t (Suc i))" + using step_Suc by auto + then have "fst (cs (S t (Suc i)) cid) = fst (cs (S t i) cid)" + by (metis Suc.prems(1) Suc.prems(3) assms(5) fst_cs_changed_by_recv_recording le_eq_less_or_eq) + also have "fst (cs (S t (Suc i)) cid) = fst (cs (S t j) cid)" + proof - + have "j - Suc i = n" using Suc by simp + moreover have "~ (\k. (Suc i) \ k \ k < j \ (\p q u u' m. t ! k = Recv cid q p u u' m) \ (snd (cs (S t k) cid) = Recording))" + using `~ ?P` Suc.prems(3) Suc_leD by blast + ultimately show ?thesis using Suc by (metis Suc_lessI) + qed + finally show ?case by simp + qed + then show False using assms `~ ?P` by blast +qed + +lemma cs_not_nil_implies_postrecording_event: + assumes + "trace init t final" and + "fst (cs (S t i) cid) \ []" and + "i \ length t" and + "channel cid = Some (p, q)" + shows + "\j. j < i \ postrecording_event t j" +proof - + have "fst (cs init cid) = []" using no_initial_channel_snapshot by auto + then have diff_cs: "fst (cs (S t 0) cid) \ fst (cs (S t i) cid)" + using assms(1) assms(2) init_is_s_t_0 by auto + moreover have "0 < i" + proof (rule ccontr) + assume "~ 0 < i" + then have "0 = i" by auto + then have "fst (cs (S t 0) cid) = fst (cs (S t i) cid)" + by blast + then show False using diff_cs by simp + qed + ultimately obtain j where "j < i" and Recv: "\p q u u' m. t ! j = Recv cid q p u u' m" "snd (cs (S t j) cid) = Recording" + using assms(1) assms(3) assms(4) fst_changed_by_recv_recording_trace by blast + then have "has_snapshotted (S t j) q" + using assms(1) assms(4) cs_recording_implies_snapshot by blast + moreover have "regular_event (t ! j)" using Recv by auto + moreover have "occurs_on (t ! j) = q" + proof - + have "can_occur (t ! j) (S t j)" + by (meson Suc_le_eq \j < i\ assms(1) assms(3) happen_implies_can_occur le_trans step_Suc) + then show ?thesis using Recv Recv_given_channel assms(4) by force + qed + ultimately have "postrecording_event t j" unfolding postrecording_event using `j < i` assms(3) by simp + then show ?thesis using `j < i` by auto +qed + +subsubsection \Relating process states\ + +lemma snapshot_state_must_have_been_reached: + assumes + "trace init t final" and + "ps final p = Some u" and + "~ has_snapshotted (S t i) p" and + "has_snapshotted (S t (i+1)) p" and + "i < length t" + shows + "states (S t i) p = u" +proof (rule ccontr) + assume "states (S t i) p \ u" + then have "ps (S t (i+1)) p \ Some u" + using assms(1) assms(3) snapshot_state by force + then have "ps final p \ Some u" + by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right assms(1) assms(3) assms(4) assms(5) final_is_s_t_len_t order_refl snapshot_state snapshot_state_unchanged_trace_2) + then show False using assms by simp +qed + +lemma ps_after_all_prerecording_events: + assumes + "trace init t final" and + "\i'. i' \ i \ ~ prerecording_event t i'" and + "\j'. j' < i \ ~ postrecording_event t j'" + shows + "ps_equal_to_snapshot (S t i) final" +proof (unfold ps_equal_to_snapshot_def, rule allI) + fix p + show "Some (states (S t i) p) = ps final p" + proof (rule ccontr) + obtain s where "ps final p = Some s \ ps final p = None" by auto + moreover assume "Some (states (S t i) p) \ ps final p" + ultimately have "ps final p = None \ states (S t i) p \ s" by auto + then show False + proof (elim disjE) + assume "ps final p = None" + then show False + using assms all_processes_snapshotted_in_final_state by blast + next + assume st: "states (S t i) p \ s" + then obtain j where "~ has_snapshotted (S t j) p \ has_snapshotted (S t (j+1)) p" + using Suc_eq_plus1 assms(1) exists_snapshot_for_all_p by presburger + then show False + proof (cases "has_snapshotted (S t i) p") + case False + then have "j \ i" + by (metis Suc_eq_plus1 \\ ps (S t j) p \ None \ ps (S t (j + 1)) p \ None\ assms(1) not_less_eq_eq snapshot_stable_ver_3) + + let ?t = "take (j-i) (drop i t)" + have "\ev. ev \ set ?t \ regular_event ev \ occurs_on ev = p" + proof (rule ccontr) + assume "~ (\ev. ev \ set ?t \ regular_event ev \ occurs_on ev = p)" + moreover have "trace (S t i) ?t (S t j)" + using \i \ j\ assms(1) exists_trace_for_any_i_j by blast + ultimately have "states (S t j) p = states (S t i) p" + using no_state_change_if_only_nonregular_events st by blast + then show False + by (metis \\ ps (S t j) p \ None \ ps (S t (j + 1)) p \ None\ \ps final p = Some s \ ps final p = None\ assms(1) final_is_s_t_len_t computation.all_processes_snapshotted_in_final_state computation.snapshot_stable_ver_3 computation_axioms linorder_not_le snapshot_state_must_have_been_reached st) + qed + + then obtain ev where "ev \ set ?t \ regular_event ev \ occurs_on ev = p" + by blast + then obtain k where t_ind: "0 \ k \ k < length ?t \ ev = ?t ! k" + by (metis in_set_conv_nth not_le not_less_zero) + moreover have "length ?t \ j - i" by simp + ultimately have "?t ! k = (drop i t) ! k" + using less_le_trans nth_take by blast + also have "... = t ! (k+i)" + by (metis \ev \ set (take (j - i) (drop i t)) \ regular_event ev \ occurs_on ev = p\ add.commute drop_eq_Nil length_greater_0_conv length_pos_if_in_set nat_le_linear nth_drop take_eq_Nil) + finally have "?t ! k = t ! (k+i)" by simp + have "prerecording_event t (k+i)" + proof - + have "regular_event (?t ! k)" + using \ev \ set (take (j - i) (drop i t)) \ regular_event ev \ occurs_on ev = p\ t_ind by blast + moreover have "occurs_on (?t ! k) = p" + using \ev \ set (take (j - i) (drop i t)) \ regular_event ev \ occurs_on ev = p\ t_ind by blast + moreover have "~ has_snapshotted (S t (k+i)) p" + proof - + have "k+i \ j" + using \length (take (j - i) (drop i t)) \ j - i\ t_ind by linarith + show ?thesis + using \\ ps (S t j) p \ None \ ps (S t (j + 1)) p \ None\ \k+i \ j\ assms(1) snapshot_stable_ver_3 by blast + qed + ultimately show ?thesis + using \take (j - i) (drop i t) ! k = t ! (k + i)\ prerecording_event t_ind by auto + qed + + then show False using assms by auto + next + case True + + have "j < i" + proof (rule ccontr) + assume "~ j < i" + then have "j \ i" by simp + moreover have "~ has_snapshotted (S t j) p" + using \\ ps (S t j) p \ None \ ps (S t (j + 1)) p \ None\ by blast + moreover have "trace (S t i) (take (j - i) (drop i t)) (S t j)" + using assms(1) calculation(1) exists_trace_for_any_i_j by blast + ultimately have "~ has_snapshotted (S t i) p" + using snapshot_stable by blast + then show False using True by simp + qed + + let ?t = "take (i-j) (drop j t)" + have "\ev. ev \ set ?t \ regular_event ev \ occurs_on ev = p" + proof (rule ccontr) + assume "~ (\ev. ev \ set ?t \ regular_event ev \ occurs_on ev = p)" + moreover have "trace (S t j) ?t (S t i)" + using \j < i\ assms(1) exists_trace_for_any_i_j less_imp_le by blast + ultimately have "states (S t j) p = states (S t i) p" + using no_state_change_if_only_nonregular_events by auto + moreover have "states (S t j) p = s" + by (metis \\ ps (S t j) p \ None \ ps (S t (j + 1)) p \ None\ \ps final p = Some s \ ps final p = None\ assms(1) final_is_s_t_len_t computation.all_processes_snapshotted_in_final_state computation.snapshot_stable_ver_3 computation_axioms linorder_not_le snapshot_state_must_have_been_reached) + ultimately show False using `states (S t i) p \ s` by simp + qed + + then obtain ev where ev: "ev \ set ?t \ regular_event ev \ occurs_on ev = p" by blast + then obtain k where t_ind: "0 \ k \ k < length ?t \ ev = ?t ! k" + by (metis in_set_conv_nth le0) + have "length ?t \ i - j" by simp + have "?t ! k = (drop j t) ! k" + using t_ind by auto + also have "... = t ! (k + j)" + by (metis \ev \ set (take (i - j) (drop j t)) \ regular_event ev \ occurs_on ev = p\ add.commute drop_eq_Nil length_greater_0_conv length_pos_if_in_set nat_le_linear nth_drop take_eq_Nil) + finally have "?t ! k = t ! (k+j)" by simp + have "postrecording_event t (k+j)" + proof - + have "trace (S t j) (take k (drop j t)) (S t (k+j))" + by (metis add_diff_cancel_right' assms(1) exists_trace_for_any_i_j le_add_same_cancel2 t_ind) + then have "has_snapshotted (S t (k+j)) p" + by (metis Suc_eq_plus1 Suc_leI \\ ps (S t j) p \ None \ ps (S t (j + 1)) p \ None\ \take (i - j) (drop j t) ! k = t ! (k + j)\ assms(1) drop_eq_Nil ev computation.snapshot_stable_ver_3 computation_axioms le_add_same_cancel2 length_greater_0_conv length_pos_if_in_set linorder_not_le order_le_less regular_event_preserves_process_snapshots step_Suc t_ind take_eq_Nil) + then show ?thesis + using \take (i - j) (drop j t) ! k = t ! (k + j)\ ev postrecording_event t_ind by auto + qed + moreover have "k + j < i" + using \length (take (i - j) (drop j t)) \ i - j\ t_ind by linarith + ultimately show False using assms(3) by simp + qed + qed + qed +qed + +subsubsection \Relating channel states\ + +lemma cs_when_recording: + shows + "\ i < j; j \ length t; trace init t final; + has_snapshotted (S t i) p; + snd (cs (S t i) cid) = Recording; + snd (cs (S t j) cid) = Done; + channel cid = Some (p, q) \ + \ map Msg (fst (cs (S t j) cid)) + = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid)" +proof (induct "j - (i+1)" arbitrary: i) + case 0 + then have "j = i+1" by simp + then have step: "(S t i) \ (t ! i) \ (S t j)" using "0.prems" step_Suc by simp + then have rm: "\q p. t ! i = RecvMarker cid q p" using done_only_from_recv_marker "0.prems" by force + then have RecvMarker: "t ! i = RecvMarker cid q p" + by (metis "0.prems"(7) RecvMarker_given_channel event.collapse(5) event.disc(25) event.inject(5) happen_implies_can_occur local.step) + then have "takeWhile ((\) Marker) (msgs (S t i) cid) = []" + proof - + have "can_occur (t ! i) (S t i)" using happen_implies_can_occur step by simp + then show ?thesis + proof - + have "\p ms. takeWhile p ms = [] \ p (hd ms::'c message)" + by (metis (no_types) hd_append2 hd_in_set set_takeWhileD takeWhile_dropWhile_id) + then show ?thesis + using \can_occur (t ! i) (S t i)\ can_occur_def rm by fastforce + qed + qed + then show ?case + using local.step rm by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis Suc_eq_plus1 less_SucI nat_induct_at_least step_Suc) + have ib: "i+1 < j \ j \ length t \ has_snapshotted (S t (i+1)) p \ snd (cs (S t j) cid) = Done" + using Suc.hyps(2) Suc.prems(2) Suc.prems(4) Suc.prems(6) local.step snapshot_state_unchanged by auto + have snap_q: "has_snapshotted (S t i) q" + using Suc(7) Suc.prems(3) Suc cs_recording_implies_snapshot by blast + then show ?case + proof (cases "t ! i") + case (Snapshot r) + then have "r \ p" + using Suc.prems(4) can_occur_def local.step by auto + then have "msgs (S t (i+1)) cid = msgs (S t i) cid" + using Snapshot local.step Suc.prems(7) by auto + moreover have "cs (S t (i+1)) cid = cs (S t i) cid" + proof - + have "r \ q" using Snapshot can_occur_def snap_q step by auto + then show ?thesis using Snapshot local.step Suc.prems(7) by auto + qed + ultimately show ?thesis using Suc ib by force + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "takeWhile ((\) Marker) (msgs (S t i) cid) = []" + proof - + have "can_occur (t ! i) (S t i)" using happen_implies_can_occur step by simp + then show ?thesis + proof - + have "\p ms. takeWhile p ms = [] \ p (hd ms::'c message)" + by (metis (no_types) hd_append2 hd_in_set set_takeWhileD takeWhile_dropWhile_id) + then show ?thesis + using RecvMarker True \can_occur (t ! i) (S t i)\ can_occur_def by fastforce + qed + qed + moreover have "snd (cs (S t (i+1)) cid) = Done" + using RecvMarker Suc.prems(1) Suc.prems(2) Suc.prems(3) True recv_marker_means_cs_Done by auto + moreover have "fst (cs (S t i) cid) = fst (cs (S t (i+1)) cid)" + using RecvMarker True local.step by auto + ultimately show ?thesis + by (metis Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(7) Suc_eq_plus1 Suc_leI append_Nil2 cs_done_implies_same_snapshots) + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis using RecvMarker step Suc False by auto + next + case False + with RecvMarker step Suc `cid \ cid'` show ?thesis by (cases "s = p", auto) + qed + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis using RecvMarker step Suc False by auto + next + case no_snap: False + then show ?thesis + proof (cases "r = q") + case True + then show ?thesis using snap_q no_snap `r = q` by simp + next + case False + then show ?thesis using RecvMarker step Suc no_snap False `cid \ cid'` by simp + qed + qed + ultimately show ?thesis using Suc ib by simp + qed + next + case (Trans r u u') + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step by auto + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Trans by auto + ultimately show ?thesis using Suc ib by simp + next + case (Send cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + have marker_in_msgs: "Marker \ set (msgs (S t i) cid)" + proof - + have "has_snapshotted (S t i) p" using Suc by simp + moreover have "i < length t" + using Suc.prems(1) Suc.prems(2) less_le_trans by blast + moreover have "snd (cs (S t i) cid) \ Done" using Suc by simp + ultimately show ?thesis using snapshotted_and_not_done_implies_marker_in_channel less_imp_le using Suc by blast + qed + then have "takeWhile ((\) Marker) (msgs (S t i) cid) = takeWhile ((\) Marker) (msgs (S t (i+1)) cid)" + proof - + have "butlast (msgs (S t (i+1)) cid) = msgs (S t i) cid" using step True Send by auto + then show ?thesis + proof - + have "takeWhile ((\) Marker) (msgs (S t i) cid @ [last (msgs (S t (i + 1)) cid)]) = takeWhile ((\) Marker) (msgs (S t i) cid)" + using marker_in_msgs by force + then show ?thesis + by (metis (no_types) \butlast (msgs (S t (i + 1)) cid) = msgs (S t i) cid\ append_butlast_last_id in_set_butlastD length_greater_0_conv length_pos_if_in_set marker_in_msgs) + qed + qed + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Send by auto + ultimately show ?thesis using ib Suc by simp + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Send by auto + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Send by auto + ultimately show ?thesis using Suc ib by simp + qed + next + case (Recv cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have msgs_ip1: "Msg m # msgs (S t (i+1)) cid = msgs (S t i) cid" + using Suc Recv step by auto + moreover have cs_ip1: "cs (S t (i+1)) cid = (fst (cs (S t i) cid) @ [m], Recording)" + using True Suc Recv step by auto + ultimately show ?thesis + proof - + have "map Msg (fst (cs (S t j) cid)) + = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (i+1)) cid)" + using Suc ib cs_ip1 by force + moreover have "map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid) + = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (i+1)) cid)" + proof - + have "takeWhile ((\) Marker) (Msg m # msgs (S t (i+1)) cid) = Msg m # takeWhile ((\) Marker) (msgs (S t (i + 1)) cid)" + by auto + then have "takeWhile ((\) Marker) (msgs (S t i) cid) = Msg m # takeWhile ((\) Marker) (msgs (S t (i + 1)) cid)" + by (metis msgs_ip1) + then show ?thesis + using cs_ip1 by auto + qed + ultimately show ?thesis by simp + qed + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Recv by auto + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Recv False by auto + ultimately show ?thesis using Suc ib by simp + qed + qed +qed + +lemma cs_when_recording_2: + shows + "\ i \ j; trace init t final; + ~ has_snapshotted (S t i) p; + \k. i \ k \ k < j \ ~ occurs_on (t ! k) = p; + snd (cs (S t i) cid) = Recording; + channel cid = Some (p, q) \ + \ map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid) + \ snd (cs (S t j) cid) = Recording" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis Suc_eq_plus1 all_processes_snapshotted_in_final_state distributed_system.step_Suc distributed_system_axioms computation.final_is_s_t_len_t computation_axioms linorder_not_le snapshot_stable_ver_3) + have ib: "i+1 \ j \ ~ has_snapshotted (S t (i+1)) p + \ (\k. (i+1) \ k \ k < j \ ~ occurs_on (t ! k) = p) \ j - (i+1) = n" + by (metis Suc.hyps(2) Suc.prems(1) Suc.prems(3) Suc.prems(4) diff_Suc_1 diff_diff_left Suc_eq_plus1 Suc_leD Suc_le_eq Suc_neq_Zero cancel_comm_monoid_add_class.diff_cancel le_neq_implies_less le_refl local.step no_state_change_if_no_event) + have snap_q: "has_snapshotted (S t i) q" + using Suc.prems(5,6) Suc.prems(2) cs_recording_implies_snapshot by blast + then show ?case + proof (cases "t ! i") + case (Snapshot r) + then have "r \ p" using Suc by auto + then have "msgs (S t (i+1)) cid = msgs (S t i) cid" + using Snapshot local.step Suc.prems(6) by auto + moreover have "cs (S t (i+1)) cid = cs (S t i) cid" + proof - + have "r \ q" using step can_occur_def Snapshot snap_q by auto + then show ?thesis using Snapshot step Suc by simp + qed + ultimately show ?thesis using Suc ib by auto + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "Marker \ set (msgs (S t i) cid)" + using RecvMarker RecvMarker_implies_Marker_in_set local.step by blast + then have "has_snapshotted (S t i) p" + using Suc.prems(2) no_marker_if_no_snapshot Suc by blast + then show ?thesis using Suc.prems by simp + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis using RecvMarker step Suc False by auto + next + case False + with RecvMarker step Suc `cid \ cid'` show ?thesis by (cases "s = p", auto) + qed + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis using RecvMarker step Suc False by auto + next + case no_snap: False + then show ?thesis + proof (cases "r = q") + case True + then show ?thesis using snap_q no_snap `r = q` by simp + next + case False + then show ?thesis using RecvMarker step Suc no_snap False `cid \ cid'` by simp + qed + qed + ultimately show ?thesis using Suc ib by auto + qed + next + case (Trans r u u') + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step by auto + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Trans by auto + ultimately show ?thesis using Suc ib by auto + next + case (Send cid' r s u u' m) + then have "r \ p" + using Suc.hyps(2) Suc.prems(4) Suc by auto + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "channel cid = channel cid'" by auto + then have "(p, q) = (r, s)" using can_occur_def step Send Suc by auto + then show False using `r \ p` by simp + qed + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Send by simp + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Send by auto + ultimately show ?thesis using Suc ib by auto + next + case (Recv cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have msgs_ip1: "Msg m # msgs (S t (i+1)) cid = msgs (S t i) cid" + using Suc Recv step by auto + moreover have cs_ip1: "cs (S t (i+1)) cid = (fst (cs (S t i) cid) @ [m], Recording)" + using True Suc Recv step by auto + ultimately show ?thesis + proof - + have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (i+1)) cid) + \ snd (cs (S t j) cid) = Recording" + using Suc ib cs_ip1 by auto + moreover have "map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid) + = map Msg (fst (cs (S t (i+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (i+1)) cid)" + proof - + have "takeWhile ((\) Marker) (Msg m # msgs (S t (i + 1)) cid) = Msg m # takeWhile ((\) Marker) (msgs (S t (i + 1)) cid)" + by fastforce + then have "takeWhile ((\) Marker) (msgs (S t i) cid) = Msg m # takeWhile ((\) Marker) (msgs (S t (i + 1)) cid)" + by (metis msgs_ip1) + then show ?thesis + using cs_ip1 by force + qed + ultimately show ?thesis using cs_ip1 by simp + qed + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Recv by auto + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" using step Recv False by auto + ultimately show ?thesis using Suc ib by auto + qed + qed +qed + +lemma cs_when_recording_3: + shows + "\ i \ j; trace init t final; + ~ has_snapshotted (S t i) q; + \k. i \ k \ k < j \ ~ occurs_on (t ! k) = q; + snd (cs (S t i) cid) = NotStarted; + has_snapshotted (S t i) p; + Marker : set (msgs (S t i) cid); + channel cid = Some (p, q) \ + \ map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid) + \ snd (cs (S t j) cid) = NotStarted" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis Suc_eq_plus1 all_processes_snapshotted_in_final_state distributed_system.step_Suc distributed_system_axioms computation.final_is_s_t_len_t computation_axioms linorder_not_le snapshot_stable_ver_3) + have ib: "i+1 \ j \ ~ has_snapshotted (S t (i+1)) q \ has_snapshotted (S t (i+1)) p + \ (\k. (i+1) \ k \ k < j \ ~ occurs_on (t ! k) = q) \ j - (i+1) = n + \ Marker : set (msgs (S t (i+1)) cid) \ cs (S t i) cid = cs (S t (i+1)) cid" + proof - + have "i+1 \ j \ ~ has_snapshotted (S t (i+1)) q + \ (\k. (i+1) \ k \ k < j \ ~ occurs_on (t ! k) = q) \ j - (i+1) = n" + by (metis Suc.hyps(2) Suc.prems(1) Suc.prems(3) Suc.prems(4) diff_Suc_1 diff_diff_left Suc_eq_plus1 Suc_leD Suc_le_eq Suc_neq_Zero cancel_comm_monoid_add_class.diff_cancel le_neq_implies_less le_refl local.step no_state_change_if_no_event) + moreover have "has_snapshotted (S t (i+1)) p" + using Suc.prems(6) local.step snapshot_state_unchanged by auto + moreover have "Marker : set (msgs (S t (i+1)) cid)" + using Suc calculation(1) local.step recv_marker_means_snapshotted_2 by blast + moreover have "cs (S t i) cid = cs (S t (i+1)) cid" + using Suc calculation(1) no_recording_cs_if_not_snapshotted by auto + ultimately show ?thesis by simp + qed + then show ?case + proof (cases "t ! i") + case (Snapshot r) + then have "r \ q" using Suc by auto + then have "takeWhile ((\) Marker) (msgs (S t (i+1)) cid) = takeWhile ((\) Marker) (msgs (S t i) cid)" + proof (cases "occurs_on (t ! i) = p") + case True + then show ?thesis + by (metis (mono_tags, lifting) Snapshot Suc.prems(6) distributed_system.can_occur_def event.sel(4) event.simps(29) computation_axioms computation_def happen_implies_can_occur local.step) + next + case False + then have "msgs (S t (i+1)) cid = msgs (S t i) cid" + using Snapshot local.step Suc by auto + then show ?thesis by simp + qed + then show ?thesis using Suc ib by metis + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "snd (cs (S t i) cid) = Done" + by (metis RecvMarker Suc.prems(2) Suc_eq_plus1 Suc_le_eq exactly_one_snapshot computation.no_change_if_ge_length_t computation.recv_marker_means_cs_Done computation.snapshot_stable_ver_2 computation_axioms ib nat_le_linear) + then show ?thesis using Suc.prems by simp + next + case False + then have "takeWhile ((\) Marker) (msgs (S t i) cid) = takeWhile ((\) Marker) (msgs (S t (i+1)) cid)" + proof (cases "has_snapshotted (S t i) r") + case True + with RecvMarker False step show ?thesis by auto + next + case no_snap: False + then have "r \ p" + using Suc.prems(6) by auto + then show ?thesis using no_snap RecvMarker step Suc.prems False by auto + qed + then show ?thesis using Suc ib by metis + qed + next + case (Trans r u u') + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step by auto + then show ?thesis using Suc ib by auto + next + case (Send cid' r s u u' m) + then have "r \ q" + using Suc.hyps(2) Suc.prems(4) by auto + have marker: "Marker \ set (msgs (S t i) cid)" using Suc by simp + with step Send marker have "takeWhile ((\) Marker) (msgs (S t i) cid) = takeWhile ((\) Marker) (msgs (S t (i+1)) cid)" + by (cases "cid = cid'", auto) + then show ?thesis using Suc ib by auto + next + case (Recv cid' r s u u' m) + then have "cid' \ cid" + by (metis Suc.hyps(2) Suc.prems(4) Suc.prems(8) distributed_system.can_occur_Recv distributed_system_axioms event.sel(3) happen_implies_can_occur local.step option.inject order_refl prod.inject zero_less_Suc zero_less_diff) + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using step Recv Suc by simp + then show ?thesis using Suc ib by auto + qed +qed + +lemma at_most_one_marker: + shows + "\ trace init t final; channel cid = Some (p, q) \ + \ Marker \ set (msgs (S t i) cid) + \ (\!j. j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j = Marker)" +proof (induct i) + case 0 + then show ?case using no_initial_Marker init_is_s_t_0 by auto +next + case (Suc i) + then show ?case + proof (cases "i < length t") + case False + then show ?thesis + by (metis Suc.prems(1) final_is_s_t_len_t computation.no_change_if_ge_length_t computation_axioms le_refl less_imp_le_nat no_marker_left_in_final_state not_less_eq) + next + case True + then have step: "(S t i) \ (t ! i) \ (S t (Suc i))" using step_Suc Suc.prems by blast + moreover have "Marker \ set (msgs (S t i) cid) + \ (\!j. j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j = Marker)" + using Suc.hyps Suc.prems(1) Suc.prems(2) by linarith + moreover have "Marker \ set (msgs (S t (Suc i)) cid) + \ (\!j. j < length (msgs (S t (Suc i)) cid) \ msgs (S t (Suc i)) cid ! j = Marker)" + proof (cases "Marker \ set (msgs (S t i) cid)") + case no_marker: True + then show ?thesis + proof (cases "t ! i") + case (Snapshot r) + then show ?thesis + proof (cases "r = p") + case True + then have new_msgs: "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Marker]" + using step Snapshot Suc by auto + then show ?thesis using util_exactly_one_element no_marker by fastforce + next + case False + then show ?thesis + using Snapshot local.step no_marker Suc by auto + qed + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then show ?thesis + using RecvMarker RecvMarker_implies_Marker_in_set local.step no_marker by blast + next + case False + then show ?thesis + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis using RecvMarker step Suc False by simp + next + case no_snap: False + then show ?thesis + proof (cases "r = p") + case True + then have "msgs (S t (i+1)) cid = msgs (S t i) cid @ [Marker]" using RecvMarker step Suc.prems no_snap `cid \ cid'` by simp + then show ?thesis + proof - + assume a1: "msgs (S t (i + 1)) cid = msgs (S t i) cid @ [Marker]" + { fix nn :: "nat \ nat" + have "\ms m. \n. \na. ((m::'c message) \ set ms \ n < length (ms @ [m])) \ (m \ set ms \ (ms @ [m]) ! n = m) \ (\ na < length (ms @ [m]) \ (ms @ [m]) ! na \ m \ m \ set ms \ na = n)" + by (metis (no_types) util_exactly_one_element) + then have "\n. n < length (msgs (S t (Suc i)) cid) \ nn n = n \ msgs (S t (Suc i)) cid ! n = Marker \ n < length (msgs (S t (Suc i)) cid) \ msgs (S t (Suc i)) cid ! n = Marker \ \ nn n < length (msgs (S t (Suc i)) cid) \ n < length (msgs (S t (Suc i)) cid) \ msgs (S t (Suc i)) cid ! n = Marker \ msgs (S t (Suc i)) cid ! nn n \ Marker" + using a1 by (metis Suc_eq_plus1 no_marker) } + then show ?thesis + by (metis (no_types)) + qed + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using RecvMarker step Suc.prems `cid \ cid'` no_snap by simp + then show ?thesis using Suc by simp + qed + qed + qed + next + case (Trans r u u') + then show ?thesis using no_marker step by auto + next + case (Send cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "Marker \ set (msgs (S t (Suc i)) cid)" using step no_marker Send by auto + then show ?thesis by simp + next + case False + then have "Marker \ set (msgs (S t (Suc i)) cid)" using step no_marker Send by auto + then show ?thesis by simp + qed + next + case (Recv cid' r s u u' m) + with step no_marker Recv show ?thesis by (cases "cid = cid'", auto) + qed + next + case False + then have asm: "\!j. j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j = Marker" + using Suc by simp + have len_filter: "length (filter ((=) Marker) (msgs (S t i) cid)) = 1" + by (metis False \Marker \ set (msgs (S t i) cid) \ (\!j. j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j = Marker)\ exists_one_iff_filter_one) + have snap_p: "has_snapshotted (S t i) p" + using False Suc.prems no_marker_if_no_snapshot by blast + show ?thesis + proof (cases "t ! i") + case (Snapshot r) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + moreover have "can_occur (t ! i) (S t i)" using happen_implies_can_occur step by blast + ultimately show False using snap_p can_occur_def Snapshot by auto + qed + then have "msgs (S t (Suc i)) cid = msgs (S t i) cid" using step Snapshot Suc by auto + then show ?thesis using asm by simp + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid" + using RecvMarker step by auto + then have "Marker \ set (msgs (S t (Suc i)) cid)" + proof - + have "\j. j \ 0 \ j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j \ Marker" + by (metis False \Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid\ asm length_pos_if_in_set nth_Cons_0) + then show ?thesis + proof - + assume a1: "\j. j \ 0 \ j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j \ Marker" + have "\ms n. ms \ msgs (S t i) cid \ length (msgs (S t (Suc i)) cid) \ n \ length ms = Suc n" + by (metis \Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid\ length_Suc_conv) + then show ?thesis + using a1 by (metis (no_types) Suc_mono Zero_not_Suc \Marker # msgs (S t (Suc i)) cid = msgs (S t i) cid\ in_set_conv_nth nth_Cons_Suc) + qed + qed + then show ?thesis by simp + next + case cid_neq_cid': False + then show ?thesis + proof (cases "has_snapshotted (S t i) r") + case True + then have "msgs (S t (Suc i)) cid = msgs (S t i) cid" + using cid_neq_cid' RecvMarker local.step snap_p by auto + then show ?thesis using asm by simp + next + case False + then have "r \ p" + using snap_p by blast + then have "msgs (S t (Suc i)) cid = msgs (S t i) cid" using cid_neq_cid' RecvMarker step False Suc by auto + then show ?thesis using asm by simp + qed + qed + next + case (Trans r u u') + then show ?thesis using step asm by auto + next + case (Send cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have new_messages: "msgs (S t (Suc i)) cid = msgs (S t i) cid @ [Msg m]" + using step Send by auto + then have "\!j. j < length (msgs (S t (Suc i)) cid) \ msgs (S t (Suc i)) cid ! j = Marker" + proof - + have "length (filter ((=) Marker) (msgs (S t (Suc i)) cid)) + = length (filter ((=) Marker) (msgs (S t i) cid)) + + length (filter ((=) Marker) [Msg m])" + by (simp add: new_messages) + then have "length (filter ((=) Marker) (msgs (S t (Suc i)) cid)) = 1" + using len_filter by simp + then show ?thesis using exists_one_iff_filter_one by metis + qed + then show ?thesis by simp + next + case False + then show ?thesis using step Send asm by auto + qed + next + case (Recv cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have new_msgs: "Msg m # msgs (S t (Suc i)) cid = msgs (S t i) cid" using step Recv by auto + then show ?thesis + proof - + have "length (filter ((=) Marker) (msgs (S t i) cid)) + = length (filter ((=) Marker) [Msg m]) + + length (filter ((=) Marker) (msgs (S t (Suc i)) cid))" + by (metis append_Cons append_Nil filter_append len_filter length_append new_msgs) + then have "length (filter ((=) Marker) (msgs (S t (Suc i)) cid)) = 1" + using len_filter by simp + then show ?thesis using exists_one_iff_filter_one by metis + qed + next + case False + then show ?thesis using step Recv asm by auto + qed + qed + qed + then show ?thesis by simp + qed +qed + +lemma last_changes_implies_send_when_msgs_nonempty: + assumes + "trace init t final" and + "msgs (S t i) cid \ []" and + "msgs (S t (i+1)) cid \ []" and + "last (msgs (S t i) cid) = Marker" and + "last (msgs (S t (i+1)) cid) \ Marker" and + "channel cid = Some (p, q)" + shows + "(\u u' m. t ! i = Send cid p q u u' m)" +proof - + have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis Suc_eq_plus1_left add.commute assms(1) assms(4) assms(5) le_Suc_eq nat_le_linear nat_less_le no_change_if_ge_length_t step_Suc) + then show ?thesis + proof (cases "t ! i") + case (Snapshot r) + then show ?thesis + by (metis assms(4) assms(5) last_snoc local.step next_snapshot) + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "last (msgs (S t i) cid) = last (msgs (S t (i+1)) cid)" + proof - + have "Marker # msgs (S t (i + 1)) cid = msgs (S t i) cid" + using RecvMarker local.step True by auto + then show ?thesis + by (metis assms(3) last_ConsR) + qed + then show ?thesis using assms by simp + next + case no_snap: False + then have "last (msgs (S t i) cid) = last (msgs (S t (i+1)) cid)" + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis using RecvMarker step no_snap by simp + next + case False + with RecvMarker step no_snap `cid \ cid'` assms show ?thesis by (cases "p = r", auto) + qed + then show ?thesis using assms by simp + qed + next + case (Trans r u u') + then show ?thesis + using assms(4) assms(5) local.step by auto + next + case (Send cid' r s u u' m) + then have "cid = cid'" + by (metis (no_types, hide_lams) assms(4) assms(5) local.step next_send) + moreover have "(p, q) = (r, s)" + proof - + have "channel cid = channel cid'" using `cid = cid'` by simp + moreover have "channel cid = Some (p, q)" using assms by simp + moreover have "channel cid' = Some (r, s)" using Send step can_occur_def by auto + ultimately show ?thesis by simp + qed + ultimately show ?thesis using Send by auto + next + case (Recv cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "last (msgs (S t i) cid) = last (msgs (S t (i+1)) cid)" + by (metis (no_types, lifting) Recv assms(3) assms(4) last_ConsR local.step next_recv) + then show ?thesis using assms by simp + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using Recv step by auto + then show ?thesis using assms by simp + qed + qed +qed + +lemma no_marker_after_RecvMarker: + assumes + "trace init t final" and + "(S t i) \ RecvMarker cid p q \ (S t (i+1))" and + "channel cid = Some (q, p)" + shows + "Marker \ set (msgs (S t (i+1)) cid)" +proof - + have new_msgs: "msgs (S t i) cid = Marker # msgs (S t (i+1)) cid" + using assms(2) by auto + have one_marker: "\!j. j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j = Marker" + by (metis assms(1,3) at_most_one_marker list.set_intros(1) new_msgs) + then obtain j where "j < length (msgs (S t i) cid)" "msgs (S t i) cid ! j = Marker" by blast + then have "j = 0" using one_marker new_msgs by auto + then have "\j. j \ 0 \ j < length (msgs (S t i) cid) \ msgs (S t i) cid ! j \ Marker" + using one_marker + using \j < length (msgs (S t i) cid)\ \msgs (S t i) cid ! j = Marker\ by blast + then have "\j. j < length (msgs (S t (i+1)) cid) \ msgs (S t (i+1)) cid ! j \ Marker" + by (metis One_nat_def Suc_eq_plus1 Suc_le_eq Suc_mono le_zero_eq list.size(4) new_msgs not_less0 nth_Cons_Suc) + then show ?thesis + by (simp add: in_set_conv_nth) +qed + +lemma no_marker_and_snapshotted_implies_no_more_markers_trace: + shows + "\ trace init t final; i \ j; j \ length t; + has_snapshotted (S t i) p; + Marker \ set (msgs (S t i) cid); + channel cid = Some (p, q) \ + \ Marker \ set (msgs (S t j) cid)" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis (no_types, hide_lams) Suc_eq_plus1 cancel_comm_monoid_add_class.diff_cancel distributed_system.step_Suc distributed_system_axioms less_le_trans linorder_not_less old.nat.distinct(2) order_eq_iff) + then have "Marker \ set (msgs (S t (i+1)) cid)" + using no_marker_and_snapshotted_implies_no_more_markers Suc step by blast + moreover have "has_snapshotted (S t (i+1)) p" + using Suc.prems(4) local.step snapshot_state_unchanged by auto + ultimately show ?case + proof - + assume a1: "ps (S t (i + 1)) p \ None" + assume a2: "Marker \ set (msgs (S t (i + 1)) cid)" + have f3: "j \ i" + using Suc.hyps(2) by force + have "j - Suc i = n" + by (metis (no_types) Suc.hyps(2) Suc.prems(2) add.commute add_Suc_right add_diff_cancel_left' le_add_diff_inverse) + then show ?thesis + using f3 a2 a1 by (metis Suc.hyps(1) Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(6) Suc_eq_plus1_left add.commute less_Suc_eq linorder_not_less) + qed +qed + +lemma marker_not_vanishing_means_always_present: + shows + "\ trace init t final; i \ j; j \ length t; + Marker : set (msgs (S t i) cid); + Marker : set (msgs (S t j) cid); + channel cid = Some (p, q) + \ \ \k. i \ k \ k \ j \ Marker : set (msgs (S t k) cid)" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis (no_types, lifting) Suc_eq_plus1 add_lessD1 distributed_system.step_Suc distributed_system_axioms le_add_diff_inverse order_le_less zero_less_Suc zero_less_diff) + have "Marker : set (msgs (S t (i+1)) cid)" + proof (rule ccontr) + assume asm: "~ Marker : set (msgs (S t (i+1)) cid)" + have snap_p: "has_snapshotted (S t i) p" + using Suc.prems(1) Suc.prems(4,6) no_marker_if_no_snapshot by blast + then have "has_snapshotted (S t (i+1)) p" + using local.step snapshot_state_unchanged by auto + then have "Marker \ set (msgs (S t j) cid)" + by (metis Suc.hyps(2) Suc.prems(1) Suc.prems(3) Suc.prems(6) asm discrete no_marker_and_snapshotted_implies_no_more_markers_trace zero_less_Suc zero_less_diff) + then show False using Suc.prems by simp + qed + then show ?case + by (meson Suc.prems(1) Suc.prems(3) Suc.prems(4) Suc.prems(5) Suc.prems(6) computation.snapshot_stable_ver_3 computation_axioms no_marker_and_snapshotted_implies_no_more_markers_trace no_marker_if_no_snapshot) +qed + +lemma last_stays_if_no_recv_marker_and_no_send: + shows "\ trace init t final; i < j; j \ length t; + last (msgs (S t i) cid) = Marker; + Marker : set (msgs (S t i) cid); + Marker : set (msgs (S t j) cid); + \k. i \ k \ k < j \ ~ (\u u' m. t ! k = Send cid p q u u' m); + channel cid = Some (p, q) \ + \ last (msgs (S t j) cid) = Marker" +proof (induct "j - (i+1)" arbitrary: i) + case 0 + then have "j = i+1" by simp + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis "0"(2) "0.prems"(2) "0.prems"(3) Suc_eq_plus1 distributed_system.step_Suc distributed_system_axioms less_le_trans) + have "Marker = last (msgs (S t (i+1)) cid)" + proof (rule ccontr) + assume "~ Marker = last (msgs (S t (i+1)) cid)" + then have "\u u' m. t ! i = Send cid p q u u' m" + proof - + have "msgs (S t (i+1)) cid \ []" using "0" `j = i+1` by auto + moreover have "msgs (S t i) cid \ []" using "0" by auto + ultimately show ?thesis + using "0.prems"(1) "0.prems"(4) "0.prems"(8) \Marker \ last (msgs (S t (i + 1)) cid)\ last_changes_implies_send_when_msgs_nonempty by auto + qed + then show False using 0 by auto + qed + then show ?case using `j = i+1` by simp +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis (no_types, hide_lams) Suc_eq_plus1 distributed_system.step_Suc distributed_system_axioms less_le_trans) + have marker_present: "Marker : set (msgs (S t (i+1)) cid)" + by (meson Suc.prems(1) Suc.prems(2) Suc.prems(3) Suc.prems(5) Suc.prems(6) Suc.prems(8) discrete le_add1 less_imp_le_nat marker_not_vanishing_means_always_present) + moreover have "Marker = last (msgs (S t (i+1)) cid)" + proof (rule ccontr) + assume asm: "~ Marker = last (msgs (S t (i+1)) cid)" + then have "\u u' m. t ! i = Send cid p q u u' m" + proof - + have "msgs (S t (i+1)) cid \ []" using marker_present by auto + moreover have "msgs (S t i) cid \ []" using Suc by auto + ultimately show ?thesis + using Suc.prems(1) Suc.prems(4) Suc.prems(8) asm last_changes_implies_send_when_msgs_nonempty by auto + qed + then show False using Suc by auto + qed + moreover have "\k. i+1 \ k \ k < j \ ~ (\u u' m. t ! k = Send cid p q u u' m)" + using Suc.prems by force + moreover have "i+1 < j" using Suc by auto + moreover have "j \ length t" using Suc by auto + moreover have "trace init t final" using Suc by auto + moreover have "Marker : set (msgs (S t j) cid)" using Suc by auto + ultimately show ?case using Suc + by (metis diff_Suc_1 diff_diff_left) +qed + +lemma last_changes_implies_send_when_msgs_nonempty_trace: + assumes + "trace init t final" + "i < j" + "j \ length t" + "Marker : set (msgs (S t i) cid)" + "Marker : set (msgs (S t j) cid)" + "last (msgs (S t i) cid) = Marker" + "last (msgs (S t j) cid) \ Marker" + "channel cid = Some (p, q)" + shows + "\k u u' m. i \ k \ k < j \ t ! k = Send cid p q u u' m" +proof (rule ccontr) + assume "~ (\k u u' m. i \ k \ k < j \ t ! k = Send cid p q u u' m)" + then have "\k. i \ k \ k < j \ ~ (\u u' m. t ! k = Send cid p q u u' m)" by blast + then have "last (msgs (S t j) cid) = Marker" using assms last_stays_if_no_recv_marker_and_no_send by blast + then show False using assms by simp +qed + +lemma msg_after_marker_and_nonempty_implies_postrecording_event: + assumes + "trace init t final" and + "Marker : set (msgs (S t i) cid)" and + "Marker \ last (msgs (S t i) cid)" and + "i \ length t" and + "channel cid = Some (p, q)" + shows + "\j. j < i \ postrecording_event t j" (is ?P) +proof - + let ?len = "length (msgs (S t i) cid)" + have "?len \ 0" using assms(2) by auto + have snap_p_i: "has_snapshotted (S t i) p" + using assms no_marker_if_no_snapshot by blast + obtain j where snap_p: "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) + have "j < i" + by (meson assms(1) computation.snapshot_stable_ver_2 computation_axioms not_less snap_p(1) snap_p_i) + have step_snap: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis Suc_eq_plus1 assms(1) l2 nat_le_linear nat_less_le snap_p(1) snapshot_stable_ver_2 step_Suc) + have re: "~ regular_event (t ! j)" + by (meson distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(1) snap_p(2) step_snap) + have op: "occurs_on (t ! j) = p" + using no_state_change_if_no_event snap_p(1) snap_p(2) step_snap by force + have marker_last: "Marker = last (msgs (S t (j+1)) cid) \ msgs (S t (j+1)) cid \ []" + proof - + have "isSnapshot (t ! j) \ isRecvMarker (t ! j)" using re nonregular_event by auto + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then have "t ! j = Snapshot p" + using op by auto + then show ?thesis using step_snap assms by auto + next + case 2 + then obtain cid' r where RecvMarker: "t ! j = RecvMarker cid' p r" + by (metis event.collapse(5) op) + then have "cid \ cid'" + using RecvMarker_implies_Marker_in_set assms(1) assms(5) no_marker_if_no_snapshot snap_p(1) step_snap by blast + then show ?thesis + using assms snap_p(1) step_snap RecvMarker by auto + qed + qed + then have "\k u u' m. j+1 \ k \ k < i \ t ! k = Send cid p q u u' m" + proof - + have "j+1 < i" + proof - + have "(S t (j+1)) \ (S t i)" + using assms(3) marker_last by auto + then have "j+1 \ i" by auto + moreover have "j+1 \ i" using `j < i` by simp + ultimately show ?thesis by simp + qed + moreover have "trace init t final" using assms by simp + moreover have "Marker = last (msgs (S t (j+1)) cid)" using marker_last by simp + moreover have "Marker : set (msgs (S t (j+1)) cid)" using marker_last by (simp add: marker_last) + ultimately show ?thesis using assms last_changes_implies_send_when_msgs_nonempty_trace by simp + qed + then obtain k where Send: "\u u' m. j+1 \ k \ k < i \ t ! k = Send cid p q u u' m" by blast + then have "postrecording_event t k" + proof - + have "k < length t" using Send assms by simp + moreover have "isSend (t ! k)" using Send by auto + moreover have "has_snapshotted (S t k) p" using Send snap_p + using assms(1) snapshot_stable_ver_3 by blast + moreover have "occurs_on (t ! k) = p" using Send by auto + ultimately show ?thesis unfolding postrecording_event by simp + qed + then show ?thesis using Send by auto +qed + +lemma same_messages_if_no_occurrence_trace: + shows + "\ trace init t final; i \ j; j \ length t; + (\k. i \ k \ k < j \ occurs_on (t ! k) \ p \ occurs_on (t ! k) \ q); + channel cid = Some (p, q) \ + \ msgs (S t i) cid = msgs (S t j) cid \ cs (S t i) cid = cs (S t j) cid" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + by (metis (no_types, hide_lams) Suc_eq_plus1 Suc_n_not_le_n diff_self_eq_0 distributed_system.step_Suc distributed_system_axioms le0 le_eq_less_or_eq less_le_trans) + then have "msgs (S t i) cid = msgs (S t (i+1)) cid \ cs (S t i) cid = cs (S t (i+1)) cid" + proof - + have "~ occurs_on (t ! i) = p" using Suc by simp + moreover have "~ occurs_on (t ! i) = q" using Suc by simp + ultimately show ?thesis using step Suc same_messages_if_no_occurrence by blast + qed + moreover have "msgs (S t (i+1)) cid = msgs (S t j) cid \ cs (S t (i+1)) cid = cs (S t j) cid" + proof - + have "i+1 \ j" using Suc by linarith + moreover have "\k. i+1 \ k \ k < j \ occurs_on (t ! k) \ p \ occurs_on (t ! k) \ q" using Suc by force + ultimately show ?thesis using Suc by auto + qed + ultimately show ?case by simp +qed + +lemma snapshot_step_cs_preservation_p: + assumes + "c \ ev \ c'" and + "~ regular_event ev" and + "occurs_on ev = p" and + "channel cid = Some (p, q)" + shows + "map Msg (fst (cs c cid)) @ takeWhile ((\) Marker) (msgs c cid) + = map Msg (fst (cs c' cid)) @ takeWhile ((\) Marker) (msgs c' cid) + \ snd (cs c cid) = snd (cs c' cid)" +proof - + have "isSnapshot ev \ isRecvMarker ev" using assms nonregular_event by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then have Snap: "ev = Snapshot p" by (metis event.collapse(4) assms(3)) + then have "fst (cs c cid) = fst (cs c' cid)" + using assms(1) assms(2) regular_event same_cs_if_not_recv by blast + moreover have "takeWhile ((\) Marker) (msgs c cid) + = takeWhile ((\) Marker) (msgs c' cid)" + proof - + have "msgs c' cid = msgs c cid @ [Marker]" using assms Snap by auto + then show ?thesis + by (simp add: takeWhile_tail) + qed + moreover have "snd (cs c cid) = snd (cs c' cid)" + using Snap assms no_self_channel by fastforce + ultimately show ?thesis by simp + next + case 2 + then obtain cid' r where RecvMarker: "ev = RecvMarker cid' p r" by (metis event.collapse(5) assms(3)) + have "cid \ cid'" + by (metis "2" RecvMarker assms(1) assms(4) distributed_system.RecvMarker_given_channel distributed_system.happen_implies_can_occur distributed_system_axioms event.sel(5,10) no_self_channel) + then have "fst (cs c cid) = fst (cs c' cid)" + using RecvMarker assms(1) assms(2) regular_event same_cs_if_not_recv by blast + moreover have "takeWhile ((\) Marker) (msgs c cid) + = takeWhile ((\) Marker) (msgs c' cid)" + proof (cases "has_snapshotted c p") + case True + then have "msgs c cid = msgs c' cid" using RecvMarker `cid \ cid'` assms by auto + then show ?thesis by simp + next + case False + then have "msgs c' cid = msgs c cid @ [Marker]" using RecvMarker `cid \ cid'` assms by auto + then show ?thesis + by (simp add: takeWhile_tail) + qed + moreover have "snd (cs c cid) = snd (cs c' cid)" + proof (cases "has_snapshotted c p") + case True + then have "cs c cid = cs c' cid" using RecvMarker `cid \ cid'` assms by simp + then show ?thesis by simp + next + case False + then show ?thesis + using RecvMarker \cid \ cid'\ assms(1) assms(4) no_self_channel by auto + qed + ultimately show ?thesis by simp + qed +qed + +lemma snapshot_step_cs_preservation_q: + assumes + "c \ ev \ c'" and + "~ regular_event ev" and + "occurs_on ev = q" and + "channel cid = Some (p, q)" and + "Marker \ set (msgs c cid)" and + "~ has_snapshotted c q" + shows + "map Msg (fst (cs c cid)) @ takeWhile ((\) Marker) (msgs c cid) + = map Msg (fst (cs c' cid)) @ takeWhile ((\) Marker) (msgs c' cid) + \ snd (cs c' cid) = Recording" +proof - + have "isSnapshot ev \ isRecvMarker ev" using assms nonregular_event by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then have Snapshot: "ev = Snapshot q" by (metis event.collapse(4) assms(3)) + then have "fst (cs c cid) = fst (cs c' cid)" + using assms(1) assms(2) regular_event same_cs_if_not_recv by blast + moreover have "takeWhile ((\) Marker) (msgs c cid) + = takeWhile ((\) Marker) (msgs c' cid)" + proof - + have "msgs c' cid = msgs c cid" using assms Snapshot + by (metis distributed_system.next_snapshot distributed_system_axioms eq_fst_iff no_self_channel option.inject) + then show ?thesis by simp + qed + moreover have "snd (cs c' cid) = Recording" using assms Snapshot by auto + ultimately show ?thesis by simp + next + case 2 + then obtain cid' r where RecvMarker: "ev = RecvMarker cid' q r" by (metis event.collapse(5) assms(3)) + have "cid \ cid'" + using RecvMarker RecvMarker_implies_Marker_in_set assms(1) assms(5) by blast + have "fst (cs c cid) = fst (cs c' cid)" + using assms(1) assms(2) regular_event same_cs_if_not_recv by blast + moreover have "takeWhile ((\) Marker) (msgs c cid) + = takeWhile ((\) Marker) (msgs c' cid)" + proof - + have "\r. channel cid = Some (q, r)" + using assms(4) no_self_channel by auto + with RecvMarker assms `cid \ cid'` have "msgs c cid = msgs c' cid" by (cases "has_snapshotted c r", auto) + then show ?thesis by simp + qed + moreover have "snd (cs c' cid) = Recording" using assms RecvMarker `cid \ cid'` by simp + ultimately show ?thesis by simp + qed +qed + +lemma Marker_in_channel_implies_not_done: + assumes + "trace init t final" and + "Marker : set (msgs (S t i) cid)" and + "channel cid = Some (p, q)" and + "i \ length t" + shows + "snd (cs (S t i) cid) \ Done" +proof (rule ccontr) + assume is_done: "~ snd (cs (S t i) cid) \ Done" + let ?t = "take i t" + have tr: "trace init ?t (S t i)" + using assms(1) exists_trace_for_any_i by blast + have "\q p. RecvMarker cid q p \ set ?t" + by (metis (mono_tags, lifting) assms(3) distributed_system.trace.simps distributed_system_axioms done_only_from_recv_marker_trace computation.no_initial_channel_snapshot computation_axioms is_done list.discI recording_state.simps(4) snd_conv tr) + then obtain j where RecvMarker: "\q p. t ! j = RecvMarker cid q p" "j < i" + by (metis (no_types, lifting) assms(4) in_set_conv_nth length_take min.absorb2 nth_take) + then have step_j: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis Suc_eq_plus1 assms(1) distributed_system.step_Suc distributed_system_axioms assms(4) less_le_trans) + then have "t ! j = RecvMarker cid q p" + by (metis RecvMarker(1) RecvMarker_given_channel assms(3) event.disc(25) event.sel(10) happen_implies_can_occur) + then have "Marker \ set (msgs (S t (j+1)) cid)" + using assms(1) assms(3) no_marker_after_RecvMarker step_j by presburger + moreover have "has_snapshotted (S t (j+1)) p" + using Suc_eq_plus1 \t ! j = RecvMarker cid q p\ assms(1) recv_marker_means_snapshotted snapshot_state_unchanged step_j by presburger + ultimately have "Marker \ set (msgs (S t i) cid)" + by (metis RecvMarker(2) Suc_eq_plus1 Suc_leI assms(1,3) assms(4) no_marker_and_snapshotted_implies_no_more_markers_trace) + then show False using assms by simp +qed + +lemma keep_empty_if_no_events: + shows + "\ trace init t final; i \ j; j \ length t; + msgs (S t i) cid = []; + has_snapshotted (S t i) p; + channel cid = Some (p, q); + \k. i \ k \ k < j \ regular_event (t ! k) \ ~ occurs_on (t ! k) = p \ + \ msgs (S t j) cid = []" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + proof - + have "i < length t" + using Suc.hyps(2) Suc.prems(3) by linarith + then show ?thesis + by (metis (full_types) Suc.prems(1) Suc_eq_plus1 step_Suc) + qed + have "msgs (S t (i+1)) cid = []" + proof (cases "t ! i") + case (Snapshot r) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + moreover have "can_occur (t ! i) (S t i)" + using happen_implies_can_occur local.step by blast + ultimately show False using can_occur_def Snapshot Suc by simp + qed + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" + using Snapshot local.step Suc by auto + then show ?thesis using Suc by simp + next + case (RecvMarker cid' r s) + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "msgs (S t i) cid \ []" + by (metis RecvMarker length_greater_0_conv linorder_not_less list.size(3) local.step nat_less_le recv_marker_other_channels_not_shrinking) + then show False using Suc by simp + qed + then show ?thesis + proof (cases "has_snapshotted (S t i) r") + case True + then have "msgs (S t (i+1)) cid = msgs (S t i) cid" using RecvMarker Suc step `cid \ cid'` by auto + then show ?thesis using Suc by simp + next + case False + have "r \ p" + using False Suc.prems(5) by blast + then show ?thesis using RecvMarker Suc step `cid \ cid'` False by simp + qed + next + case (Trans r u u') + then show ?thesis using Suc step by simp + next + case (Send cid' r s u u' m) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + then have "occurs_on (t ! i) = p \ regular_event (t ! i)" using Send by simp + moreover have "i \ i \ i < j" using Suc by simp + ultimately show False using Suc.prems by blast + qed + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "channel cid = channel cid'" by auto + then have "channel cid' = Some (r, s)" using Send step can_occur_def by simp + then show False using Suc `r \ p` `~ cid \ cid'` by auto + qed + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" + using step Send Suc by simp + then show ?thesis using Suc by simp + next + case (Recv cid' r s u u' m) + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "msgs (S t i) cid \ []" + using Recv local.step by auto + then show False using Suc by simp + qed + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using Recv step by auto + then show ?thesis using Suc by simp + qed + moreover have "\k. i+1 \ k \ k < j \ regular_event (t ! k) \ ~ occurs_on (t ! k) = p" + using Suc by simp + moreover have "has_snapshotted (S t (i+1)) p" + by (meson Suc.prems(1) Suc.prems(5) discrete less_not_refl nat_le_linear snapshot_stable_ver_3) + moreover have "i+1 \ j" using Suc by simp + moreover have "j \ length t" using Suc by simp + moreover have "j - (i+1) = n" using Suc by linarith + ultimately show ?case using Suc by blast +qed + +lemma last_unchanged_or_empty_if_no_events: + shows + "\ trace init t final; i \ j; j \ length t; + msgs (S t i) cid \ []; + last (msgs (S t i) cid) = Marker; + has_snapshotted (S t i) p; + channel cid = Some (p, q); + \k. i \ k \ k < j \ regular_event (t ! k) \ ~ occurs_on (t ! k) = p \ + \ msgs (S t j) cid = [] \ (msgs (S t j) cid \ [] \ last (msgs (S t j) cid) = Marker)" +proof (induct "j - i" arbitrary: i) + case 0 + then show ?case + by auto +next + case (Suc n) + then have step: "(S t i) \ (t ! i) \ (S t (i+1))" + proof - + have "i < length t" + using Suc.hyps(2) Suc.prems(3) by linarith + then show ?thesis + by (metis (full_types) Suc.prems(1) Suc_eq_plus1 step_Suc) + qed + have msgs_s_ip1: "msgs (S t (i+1)) cid = [] \ (msgs (S t (i+1)) cid \ [] \ last (msgs (S t (i+1)) cid) = Marker)" + proof (cases "t ! i") + case (Snapshot r) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + moreover have "can_occur (t ! i) (S t i)" + using happen_implies_can_occur local.step by blast + ultimately show False using can_occur_def Snapshot Suc by simp + qed + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" + using Snapshot local.step Suc by auto + then show ?thesis using Suc by simp + next + case (RecvMarker cid' r s) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "msgs (S t (i+1)) cid = []" + proof - + have "Marker # msgs (S t (i+1)) cid = msgs (S t i) cid" + using RecvMarker True local.step by auto + then show ?thesis + proof - + assume a1: "Marker # msgs (S t (i + 1)) cid = msgs (S t i) cid" + have "i < j" + by (metis (no_types) Suc.hyps(2) Suc.prems(2) Suc_neq_Zero diff_is_0_eq le_neq_implies_less) + then have "i < length t" + using Suc.prems(3) less_le_trans by blast + then show ?thesis + using a1 by (metis (no_types) Marker_in_channel_implies_not_done RecvMarker Suc.prems(1) Suc.prems(5) Suc.prems(7) Suc_eq_plus1 Suc_le_eq True last_ConsR last_in_set recv_marker_means_cs_Done) + qed + qed + then show ?thesis by simp + next + case False + then show ?thesis + proof (cases "has_snapshotted (S t i) r") + case True + then show ?thesis + using False RecvMarker Suc.prems(5) local.step by auto + next + case False + then have "r \ p" + using Suc.prems(6) by blast + with RecvMarker False Suc.prems step `cid \ cid'` show ?thesis by auto + qed + qed + next + case (Trans r u u') + then show ?thesis using Suc step by simp + next + case (Send cid' r s u u' m) + have "r \ p" + proof (rule ccontr) + assume "~ r \ p" + then have "occurs_on (t ! i) = p \ regular_event (t ! i)" using Send by simp + moreover have "i \ i \ i < j" using Suc by simp + ultimately show False using Suc.prems by blast + qed + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "channel cid = channel cid'" by auto + then have "channel cid' = Some (r, s)" using Send step can_occur_def by simp + then show False using Suc `r \ p` `~ cid \ cid'` by auto + qed + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" + using step Send by simp + then show ?thesis using Suc by simp + next + case (Recv cid' r s u u' m) + then show ?thesis + proof (cases "cid = cid'") + case True + then have "msgs (S t i) cid = Msg m # msgs (S t (i+1)) cid" + using Recv local.step by auto + then have "last (msgs (S t (i+1)) cid) = Marker" + by (metis Suc.prems(5) last.simps message.simps(3)) + then show ?thesis by blast + next + case False + then have "msgs (S t i) cid = msgs (S t (i+1)) cid" using Recv step by auto + then show ?thesis using Suc by simp + qed + qed + then show ?case + proof (elim disjE, goal_cases) + case 1 + moreover have "trace init t final" using Suc by simp + moreover have "i+1 \ j" using Suc by simp + moreover have "j \ length t" using Suc by simp + moreover have "has_snapshotted (S t (i+1)) p" + using Suc.prems(6) local.step snapshot_state_unchanged by auto + moreover have "j - (i+1) = n" using Suc by linarith + moreover have "\k. i+1 \ k \ k < j \ regular_event (t ! k) \ ~ occurs_on (t ! k) = p" + using Suc by auto + ultimately have "msgs (S t j) cid = []" using keep_empty_if_no_events Suc.prems(7) by blast + then show ?thesis by simp + next + case 2 + moreover have "trace init t final" using Suc by simp + moreover have "i+1 \ j" using Suc by simp + moreover have "j \ length t" using Suc by simp + moreover have "has_snapshotted (S t (i+1)) p" + using Suc.prems(6) local.step snapshot_state_unchanged by auto + moreover have "j - (i+1) = n" using Suc by linarith + moreover have "\k. i+1 \ k \ k < j \ regular_event (t ! k) \ ~ occurs_on (t ! k) = p" + using Suc by auto + ultimately show ?thesis using Suc.prems(7) Suc.hyps by blast + qed +qed + +lemma cs_after_all_prerecording_events: + assumes + "trace init t final" and + "\i'. i' \ i \ ~ prerecording_event t i'" and + "\j'. j' < i \ ~ postrecording_event t j'" and + "i \ length t" + shows + "cs_equal_to_snapshot (S t i) final" +proof (unfold cs_equal_to_snapshot_def, rule allI, rule impI) + fix cid + assume "channel cid \ None" + then obtain p q where chan: "channel cid = Some (p, q)" by auto + have cs_done: "snd (cs (S t (length t)) cid) = Done" + using chan all_channels_done_in_final_state assms(1) final_is_s_t_len_t by blast + have "filter ((\) Marker) (msgs (S t i) cid) = takeWhile ((\) Marker) (msgs (S t i) cid)" (is ?B) + proof (rule ccontr) + let ?m = "msgs (S t i) cid" + assume "~ ?B" + then obtain j k where range: "j < k" "k < length ?m" and "?m ! j = Marker" "?m ! k \ Marker" + using filter_neq_takeWhile by metis + then have "Marker \ set ?m" + by (metis less_trans nth_mem) + moreover have "last ?m \ Marker" + proof - + have "\l. l < length ?m \ l \ j \ ?m ! l \ Marker" + using chan \j < k\ \k < length (msgs (S t i) cid)\ \msgs (S t i) cid ! j = Marker\ assms(1) at_most_one_marker calculation less_trans by blast + moreover have "last ?m = ?m ! (length ?m - 1)" + by (metis \Marker \ set (msgs (S t i) cid)\ empty_iff last_conv_nth list.set(1)) + moreover have "length ?m - 1 \ j" using range by auto + ultimately show ?thesis using range by auto + qed + moreover have "i \ length t" + using chan assms(1) calculation(1) computation.exists_next_marker_free_state computation.no_change_if_ge_length_t computation_axioms nat_le_linear by fastforce + ultimately have "\j. j < i \ postrecording_event t j" + using chan assms(1) msg_after_marker_and_nonempty_implies_postrecording_event by auto + then show False using assms by auto + qed + moreover have "takeWhile ((\) Marker) (msgs (S t i) cid) = map Msg (fst (cs final cid))" + proof (cases "snd (cs (S t i) cid)") + case NotStarted + text \show that q and p have to snapshot, and then reduce it to the case below depending on + the order they snapshotted in\ + have nsq: "~ has_snapshotted (S t i) q" + using NotStarted chan assms(1) cs_in_initial_state_implies_not_snapshotted by auto + obtain j where snap_q: "~ has_snapshotted (S t j) q" "has_snapshotted (S t (j+1)) q" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) + have step_q: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis \\ ps (S t j) q \ None\ add.commute assms(1) le_SucI le_eq_less_or_eq le_refl linorder_neqE_nat no_change_if_ge_length_t plus_1_eq_Suc snap_q step_Suc) + obtain k where snap_p: "~ has_snapshotted (S t k) p" "has_snapshotted (S t (k+1)) p" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) + have bound: "i \ j" + proof (rule ccontr) + assume "~ i \ j" + then have "i \ j+1" by simp + then have "has_snapshotted (S t i) q" + by (meson assms(1) computation.snapshot_stable_ver_3 computation_axioms snap_q(2)) + then show False using nsq by simp + qed + have step_p: "(S t k) \ (t ! k) \ (S t (k+1))" + by (metis \\ ps (S t k) p \ None\ add.commute assms(1) le_SucI le_eq_less_or_eq le_refl linorder_neqE_nat no_change_if_ge_length_t plus_1_eq_Suc snap_p step_Suc) + have oq: "occurs_on (t ! j) = q" + proof (rule ccontr) + assume "~ occurs_on (t ! j) = q" + then have "has_snapshotted (S t j) q = has_snapshotted (S t (j+1)) q" + using no_state_change_if_no_event step_q by auto + then show False using snap_q by blast + qed + have op: "occurs_on (t ! k) = p" + proof (rule ccontr) + assume "~ occurs_on (t ! k) = p" + then have "has_snapshotted (S t k) p = has_snapshotted (S t (k+1)) p" + using no_state_change_if_no_event step_p by auto + then show False using snap_p by blast + qed + have "p \ q" using chan no_self_channel by blast + then have "j \ k" using oq op event_occurs_on_unique by blast + show ?thesis + proof (cases "j < k") + case True + then have "msgs (S t i) cid = msgs (S t j) cid \ cs (S t i) cid = cs (S t j) cid" + proof - + have "\k. i \ k \ k < j \ occurs_on (t ! k) \ p \ occurs_on (t ! k) \ q" (is ?Q) + proof (rule ccontr) + assume "~ ?Q" + then obtain l where range: "i \ l" "l < j" and "occurs_on (t ! l) = p \ occurs_on (t ! l) = q" by blast + then show False + proof (elim disjE, goal_cases) + case 1 + then show ?thesis + proof (cases "regular_event (t ! l)") + case True + have "l < k" using range `j < k` by simp + have "~ has_snapshotted (S t l) p" using snap_p(1) range `j < k` snapshot_stable_ver_3 assms(1) by simp + then have "prerecording_event t l" using True "1" prerecording_event + using s_def snap_q(1) snap_q(2) by fastforce + then show False using assms range by blast + next + case False + then have step_l: "(S t l) \ t ! l \ (S t (l+1))" + by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD True assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all) + then have "has_snapshotted (S t (l+1)) p" using False nonregular_event_induces_snapshot + by (metis "1"(3) snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI True assms(1) less_imp_le_nat local.range(2) snap_p(1) snapshot_stable_ver_3) + qed + next + case 2 + then show ?thesis + proof (cases "regular_event (t ! l)") + case True + have "~ has_snapshotted (S t l) q" using snap_q(1) range `j < k` snapshot_stable_ver_3 assms(1) by simp + then have "prerecording_event t l" using True "2" prerecording_event + using s_def snap_q(2) by fastforce + then show False using assms range by blast + next + case False + then have step_l: "(S t l) \ t ! l \ (S t (l+1))" + by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD True assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all) + then have "has_snapshotted (S t (l+1)) q" using False nonregular_event_induces_snapshot + by (metis "2"(3) snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI assms(1) range(2) snap_q(1) snapshot_stable_ver_3) + qed + qed + qed + moreover have "j \ length t" + proof (rule ccontr) + assume "~ j \ length t" + then have "S t j = S t (j+1)" using no_change_if_ge_length_t assms by simp + then show False using snap_q by auto + qed + ultimately show ?thesis using chan same_messages_if_no_occurrence_trace assms less_imp_le bound by blast + qed + moreover have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (j+1)) cid) + \ snd (cs (S t (j+1)) cid) = Recording" + proof - + have "~ regular_event (t ! j)" using snap_q + using regular_event_cannot_induce_snapshot step_q by blast + moreover have "Marker \ set (msgs (S t j) cid)" + by (meson chan True assms(1) computation.no_marker_if_no_snapshot computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_p(1)) + ultimately show ?thesis using oq snapshot_step_cs_preservation_q step_q chan snap_q(1) by blast + qed + moreover have "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) + = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (j+1)) cid)" + proof - + have "snd (cs (S t (j+1)) cid) = Recording" using calculation by simp + moreover have "\a. j+1 \ a \ a < k \ ~ occurs_on (t ! a) = p" (is ?R) + proof (rule ccontr) + assume "~ ?R" + then obtain a where "j+1 \ a" "a < k" and ocp: "occurs_on (t ! a) = p" by blast + have "a < length t" + proof - + have "k < length t" + proof (rule ccontr) + assume "~ k < length t" + then have "S t k = S t (k+1)" + using assms(1) no_change_if_ge_length_t by auto + then show False using snap_p by auto + qed + then show ?thesis using `a < k` by simp + qed + then show False + proof (cases "regular_event (t ! a)") + case True + have "~ has_snapshotted (S t a) p" + by (meson \a < k\ assms(1) computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_p(1)) + then have "prerecording_event t a" using `a < length t` ocp True prerecording_event by simp + then show False using `j+1 \ a` `j \ i` assms by auto + next + case False + then have "(S t a) \ (t ! a) \ (S t (a+1))" + using \a < length t\ assms(1) step_Suc by auto + then have "has_snapshotted (S t (a+1)) p" + by (metis False ocp nonregular_event_induces_snapshot snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI \a < k\ assms(1) snap_p(1) snapshot_stable_ver_3) + qed + qed + moreover have "~ has_snapshotted (S t (j+1)) p" + by (metis Suc_eq_plus1 Suc_le_eq True assms(1) computation.snapshot_stable_ver_2 computation_axioms snap_p(1)) + ultimately show ?thesis using chan cs_when_recording_2 True assms(1) by auto + qed + moreover have "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) + = map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k+1)) cid)" + proof - + have "\ regular_event (t ! k)" + using regular_event_preserves_process_snapshots snap_p(1) snap_p(2) step_p by force + then show ?thesis + using chan computation.snapshot_step_cs_preservation_p computation_axioms op step_p by fastforce + qed + moreover have "map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k+1)) cid) + = map Msg (fst (cs final cid))" + proof - + have f1: "\f p pa pb c ca es n a na. \ computation f p pa pb (c::('a, 'b, 'c) configuration) ca \ \ distributed_system.trace f p pa pb c es ca \ ps (distributed_system.s f p pa pb c es n) a = None \ \ n \ na \ ps (distributed_system.s f p pa pb c es na) a \ None" + by (meson computation.snapshot_stable_ver_2) + have f2: "computation channel trans send recv init (S t (length t))" + using assms(1) final_is_s_t_len_t computation_axioms by blast + have f3: "trace init t (S t (length t))" + using assms(1) final_is_s_t_len_t by blast + have f4: "ps (S t k) p = None" + by (meson snap_p(1)) + then have f5: "k < length t" + using f3 f2 f1 by (metis le_eq_less_or_eq not_le s_def snap_p(2) take_all) + have "\ regular_event (t ! k)" + using f4 by (meson distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(2) step_p) + then have f6: "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k + 1)) cid) \ snd (cs (S t k) cid) = snd (cs (S t (k + 1)) cid)" + using chan computation.snapshot_step_cs_preservation_p computation_axioms op step_p by fastforce + then have f7: "snd (cs (S t (k + 1)) cid) \ Done" + using f5 f4 by (metis (no_types) assms(1) chan cs_done_implies_both_snapshotted(1)) + have "j + 1 \ k + 1" + using True by linarith + then have "snd (cs (S t (k + 1)) cid) = Recording" + using f7 f3 f2 f1 by (meson chan computation.cs_in_initial_state_implies_not_snapshotted recording_state.exhaust snap_q(2)) + then show ?thesis + using f6 f5 by (metis (no_types) Suc_eq_plus1 Suc_leI assms(1) chan cs_done cs_done_implies_both_snapshotted(1) cs_when_recording final_is_s_t_len_t le_eq_less_or_eq snap_p(2)) + qed + ultimately show ?thesis + by (metis (no_types, lifting) chan Nil_is_map_conv assms(1) computation.no_initial_channel_snapshot computation_axioms fst_conv no_recording_cs_if_not_snapshotted self_append_conv2 snap_q(1)) + next + case False + then have "k < j" using `j \ k` False by simp + then have "map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid) + = map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid)" + proof (cases "i \ k") + case True + then have "msgs (S t i) cid = msgs (S t k) cid \ cs (S t i) cid = cs (S t k) cid" + proof - + have "\j. i \ j \ j < k \ occurs_on (t ! j) \ p \ occurs_on (t ! j) \ q" (is ?Q) + proof (rule ccontr) + assume "~ ?Q" + then obtain l where range: "i \ l" "l < k" and "occurs_on (t ! l) = p \ occurs_on (t ! l) = q" by blast + then show False + proof (elim disjE, goal_cases) + case 1 + then show ?thesis + proof (cases "regular_event (t ! l)") + case True + have "l < k" using range `k < j` by simp + have "~ has_snapshotted (S t l) p" using snap_p(1) range `k < j` snapshot_stable_ver_3 assms(1) by simp + then have "prerecording_event t l" using True "1" prerecording_event + using s_def snap_p by fastforce + then show False using assms range by blast + next + case False + then have step_l: "(S t l) \ t ! l \ (S t (l+1))" + by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all) + then have "has_snapshotted (S t (l+1)) p" using False nonregular_event_induces_snapshot + by (metis "1"(3) snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI assms(1) local.range(2) snap_p(1) snapshot_stable_ver_3) + qed + next + case 2 + then show ?thesis + proof (cases "regular_event (t ! l)") + case True + have "~ has_snapshotted (S t l) p" using snap_p(1) range `k < j` snapshot_stable_ver_3 assms(1) by simp + moreover have "l < length t" + using \k < j\ local.range(2) s_def snap_q(1) snap_q(2) by force + ultimately have "prerecording_event t l" using True "2" prerecording_event + proof - + have "l \ j" + by (meson False \l < k\ less_trans not_less) + then show ?thesis + by (metis (no_types) True \l < length t\ \occurs_on (t ! l) = q\ assms(1) computation.prerecording_event computation.snapshot_stable_ver_2 computation_axioms snap_q(1)) + qed + then show False using assms range by blast + next + case False + then have step_l: "(S t l) \ t ! l \ (S t (l+1))" + by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessD assms(1) distributed_system.step_Suc distributed_system_axioms less_trans_Suc linorder_not_le local.range(2) s_def snap_p(1) snap_p(2) take_all) + then have "has_snapshotted (S t (l+1)) q" using False nonregular_event_induces_snapshot + by (metis "2"(3) snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI \k < j\ assms(1) less_imp_le_nat local.range(2) snap_q(1) snapshot_stable_ver_3) + qed + qed + qed + moreover have "k \ length t" + proof (rule ccontr) + assume "~ k \ length t" + then have "S t k = S t (k+1)" using no_change_if_ge_length_t assms by simp + then show False using snap_p by auto + qed + ultimately show ?thesis using chan same_messages_if_no_occurrence_trace assms True less_imp_le by auto + qed + moreover have "map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) + = map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k+1)) cid) + \ snd (cs (S t (k+1)) cid) = NotStarted" + proof - + have "~ regular_event (t ! k)" using snap_p + using regular_event_cannot_induce_snapshot step_p by blast + then show ?thesis + using calculation op snapshot_step_cs_preservation_p step_p chan NotStarted by auto + qed + moreover have "map Msg (fst (cs (S t (k+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k+1)) cid) + = map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid)" + proof - + have "\a. k+1 \ a \ a < j \ ~ occurs_on (t ! a) = q" (is ?R) + proof (rule ccontr) + assume "~ ?R" + then obtain a where "k+1 \ a" "a < j" and ocp: "occurs_on (t ! a) = q" by blast + have "a < length t" + proof - + have "j < length t" + proof (rule ccontr) + assume "~ j < length t" + then have "S t j = S t (j+1)" + using assms(1) no_change_if_ge_length_t by auto + then show False using snap_q by auto + qed + then show ?thesis using `a < j` by simp + qed + then show False + proof (cases "regular_event (t ! a)") + case True + have "~ has_snapshotted (S t a) q" + by (meson \a < j\ assms(1) computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_q(1)) + then have "prerecording_event t a" using `a < length t` ocp True prerecording_event by simp + then show False using `k+1 \ a` `k \ i` assms by auto + next + case False + then have "(S t a) \ (t ! a) \ (S t (a+1))" + using \a < length t\ assms(1) step_Suc by auto + then have "has_snapshotted (S t (a+1)) q" + by (metis False ocp nonregular_event_induces_snapshot snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI \a < j\ assms(1) snap_q(1) snapshot_stable_ver_3) + qed + qed + moreover have "Marker : set (msgs (S t (k+1)) cid)" + using chan \map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k + 1)) cid) \ snd (cs (S t (k + 1)) cid) = NotStarted\ assms(1) cs_in_initial_state_implies_not_snapshotted marker_must_stay_if_no_snapshot snap_p(2) by blast + moreover have "has_snapshotted (S t (k+1)) p" + using snap_p(2) by blast + moreover have "~ has_snapshotted (S t (k+1)) q" + using chan \map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k + 1)) cid) \ snd (cs (S t (k + 1)) cid) = NotStarted\ assms(1) cs_in_initial_state_implies_not_snapshotted by blast + moreover have "k+1 \ j" + using \k < j\ by auto + moreover have "trace init t final" using assms by simp + moreover have "snd (cs (S t (k+1)) cid) = NotStarted" + using \map Msg (fst (cs (S t k) cid)) @ takeWhile ((\) Marker) (msgs (S t k) cid) = map Msg (fst (cs (S t (k + 1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (k + 1)) cid) \ snd (cs (S t (k + 1)) cid) = NotStarted\ by blast + ultimately show ?thesis using cs_when_recording_3 chan by simp + qed + ultimately show ?thesis by simp + next + case False + show ?thesis + proof - + have "has_snapshotted (S t i) p" + by (metis False Suc_eq_plus1 assms(1) not_less_eq_eq snap_p(2) snapshot_stable_ver_3) + moreover have "~ has_snapshotted (S t i) q" + using nsq by auto + moreover have "Marker : set (msgs (S t i) cid)" + using chan assms(1) calculation(1) marker_must_stay_if_no_snapshot nsq by blast + moreover have "\k. i \ k \ k < j \ ~ occurs_on (t ! k) = q" (is ?R) + proof (rule ccontr) + assume "~ ?R" + then obtain k where "i \ k" "k < j" and ocp: "occurs_on (t ! k) = q" by blast + have "k < length t" + proof - + have "j < length t" + proof (rule ccontr) + assume "~ j < length t" + then have "S t j = S t (j+1)" + using assms(1) no_change_if_ge_length_t by auto + then show False using snap_q by auto + qed + then show ?thesis using `k < j` by simp + qed + then show False + proof (cases "regular_event (t ! k)") + case True + have "~ has_snapshotted (S t k) q" + by (meson `k < j` assms(1) computation.snapshot_stable_ver_2 computation_axioms less_imp_le_nat snap_q(1)) + then have "prerecording_event t k" using `k < length t` ocp True prerecording_event by simp + then show False using `i \ j` `k \ i` assms by auto + next + case False + then have "(S t k) \ (t ! k) \ (S t (k+1))" + using \k < length t\ assms(1) step_Suc by auto + then have "has_snapshotted (S t (k+1)) q" + by (metis False ocp nonregular_event_induces_snapshot snapshot_state_unchanged) + then show False + by (metis Suc_eq_plus1 Suc_leI \k < j\ assms(1) snap_q(1) snapshot_stable_ver_3) + qed + qed + ultimately show ?thesis using cs_when_recording_3 + using NotStarted assms(1) bound chan by auto + qed + qed + moreover have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs final cid))" + proof (cases "\q p. t ! j = RecvMarker cid q p") + case True + then have "fst (cs (S t j) cid) = fst (cs (S t (j+1)) cid)" + using step_q by auto + moreover have RecvMarker: "t ! j = RecvMarker cid q p" + proof - + have "can_occur (t ! j) (S t j)" using happen_implies_can_occur step_q by simp + then show ?thesis + using RecvMarker_given_channel True chan by force + qed + moreover have "takeWhile ((\) Marker) (msgs (S t j) cid) = []" + proof - + have "can_occur (t ! j) (S t j)" using happen_implies_can_occur step_q by simp + then have "length (msgs (S t j) cid) > 0 \ hd (msgs (S t j) cid) = Marker" + using RecvMarker can_occur_def by auto + then show ?thesis + by (metis (mono_tags, lifting) hd_conv_nth length_greater_0_conv nth_mem set_takeWhileD takeWhile_nth) + qed + moreover have "snd (cs (S t (j+1)) cid) = Done" using step_q True by auto + moreover have "cs (S t (j+1)) cid = cs final cid" using chan calculation cs_done_implies_same_snapshots assms(1) + by (metis final_is_s_t_len_t nat_le_linear no_change_if_ge_length_t) + ultimately show ?thesis + by simp + next + case False + have "~ regular_event (t ! j)" + using regular_event_preserves_process_snapshots snap_q(1) snap_q(2) step_q by auto + then have "isSnapshot (t ! j) \ isRecvMarker (t ! j)" using nonregular_event by auto + then have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (j+1)) cid) + \ snd (cs (S t (j+1)) cid) = Recording" + proof (elim disjE, goal_cases) + case 1 + have Snapshot: "t ! j = Snapshot q" + using "1" oq by auto + then have "msgs (S t j) cid = msgs (S t (j+1)) cid" + using \p \ q\ step_q chan by auto + moreover have "cs (S t (j+1)) cid = (fst (cs (S t j) cid), Recording)" + using step_q Snapshot chan by simp + ultimately show ?thesis by simp + next + case 2 + obtain cid' r where RecvMarker: "t ! j = RecvMarker cid' q r" + by (metis "2" event.collapse(5) oq) + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "channel cid = channel cid'" by simp + then have "channel cid' = Some (r, q)" + using False RecvMarker \\ cid \ cid'\ by blast + then show False + using False RecvMarker \\ cid \ cid'\ by blast + qed + then have "msgs (S t j) cid = msgs (S t (j+1)) cid" + using `cid \ cid'` step_q snap_q RecvMarker chan `p \ q` by simp + moreover have "cs (S t (j+1)) cid = (fst (cs (S t j) cid), Recording)" + using \p \ q\ `cid \ cid'`step_q snap_q RecvMarker chan by auto + ultimately show ?thesis by simp + qed + moreover have "map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (j+1)) cid) + = map Msg (fst (cs final cid))" + proof - + have "snd (cs (S t (j+1)) cid) = Recording" + using calculation by blast + moreover have "has_snapshotted (S t (j+1)) p" + by (metis Suc_eq_plus1 Suc_leI \k < j\ assms(1) le_add1 snap_p(2) snapshot_stable_ver_3) + moreover have "has_snapshotted (S t (j+1)) q" using snap_q by auto + moreover have "j < length t" + by (metis (no_types, lifting) chan Suc_eq_plus1 assms(1) cs_done cs_done_implies_both_snapshotted(2) computation.no_change_if_ge_length_t computation.snapshot_stable_ver_3 computation_axioms leI le_Suc_eq snap_q(1) snap_q(2)) + ultimately show ?thesis using cs_when_recording assms(1) cs_done final_is_s_t_len_t + proof - + assume a1: "j < length t" + assume a2: "trace init t final" + assume a3: "snd (cs (S t (length t)) cid) = Done" + assume a4: "snd (cs (S t (j + 1)) cid) = Recording" + assume a5: "ps (S t (j + 1)) p \ None" + assume a6: "\t. trace init t final \ final = S t (length t)" + assume a7: "\i j t p cid q. \i < j; j \ length t; trace init t final; ps (S t i) p \ None; snd (cs (S t i) cid) = Recording; snd (cs (S t j) cid) = Done; channel cid = Some (p, q)\ \ map Msg (fst (cs (S t j) cid)) = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid)" + have "Suc j < length t" + using a3 a2 a1 by (metis (no_types) False Suc_eq_plus1 Suc_lessI chan cs_done_implies_has_snapshotted done_only_from_recv_marker snap_q(1) step_q) + then show ?thesis + using a7 a6 a5 a4 a3 a2 by (metis (no_types) Suc_eq_plus1 chan nat_le_linear) + qed + qed + ultimately show ?thesis by simp + qed + ultimately show ?thesis + by (metis (no_types, lifting) Nil_is_map_conv assms(1) assms(3) chan cs_done cs_done_implies_has_snapshotted cs_not_nil_implies_postrecording_event nat_le_linear nsq self_append_conv2 snapshot_stable_ver_3) + qed + next + case Recording + then obtain j where snap_p: "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) + have snap_q: "has_snapshotted (S t i) q" + using Recording assms(1) chan cs_recording_implies_snapshot by blast + have fst_cs_empty: "cs (S t i) cid = ([], Recording)" (is ?P) + proof (rule ccontr) + assume "~ ?P" + have "snd (cs (S t i) cid) = Recording" using Recording by simp + moreover have "fst (cs (S t i) cid) \ []" using `~ ?P` prod.collapse calculation by metis + ultimately have "\j. j < i \ postrecording_event t j" + using assms(1) assms(4) chan cs_not_nil_implies_postrecording_event by blast + then show False using assms by auto + qed + then show ?thesis + proof - + have i_less_len_t: "i < length t" + proof (rule ccontr) + assume "~ i < length t" + then have "snd (cs (S t i) cid) = Done" + by (metis assms(1) cs_done le_eq_less_or_eq nat_le_linear no_change_if_ge_length_t) + then show False using Recording by simp + qed + then have "map Msg (fst (cs final cid)) + = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid)" + proof (cases "j < i") + case True + then have "has_snapshotted (S t i) p" + by (metis Suc_eq_plus1 Suc_leI assms(1) snap_p(2) snapshot_stable_ver_3) + moreover have "length t \ length t" by simp + ultimately show ?thesis + using Recording chan assms(1) cs_done cs_when_recording final_is_s_t_len_t i_less_len_t by blast + next + case False + text \need to show that next message that comes into the channel must be marker\ + have "\k. i \ k \ k < j \ ~ occurs_on (t ! k) = p" (is ?P) + proof (rule ccontr) + assume "~ ?P" + then obtain k where "i \ k" "k < j" "occurs_on (t ! k) = p" by blast + then show False + proof (cases "regular_event (t ! k)") + case True + then have "prerecording_event t k" + by (metis (no_types, hide_lams) \k < j\ \occurs_on (t ! k) = p\ all_processes_snapshotted_in_final_state assms(1) final_is_s_t_len_t computation.prerecording_event computation_axioms less_trans nat_le_linear not_less snap_p(1) snapshot_stable_ver_2) + then show ?thesis using assms `i \ k` by auto + next + case False + then have step_k: "(S t k) \ (t ! k) \ (S t (Suc k))" + by (metis (no_types, lifting) Suc_leI \k < j\ all_processes_snapshotted_in_final_state assms(1) final_is_s_t_len_t le_Suc_eq less_imp_Suc_add linorder_not_less no_change_if_ge_length_t snap_p(1) step_Suc) + then have "has_snapshotted (S t (Suc k)) p" + by (metis False \occurs_on (t ! k) = p\ nonregular_event_induces_snapshot snapshot_state_unchanged) + then have "k \ j" + by (metis Suc_leI \k < j\ assms(1) snap_p(1) snapshot_stable_ver_3) + then show False using `k < j` by simp + qed + qed + moreover have "~ has_snapshotted (S t i) p" + using False assms(1) snap_p(1) snapshot_stable_ver_3 by auto + ultimately have to_snapshot: "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t i) cid)) @ takeWhile ((\) Marker) (msgs (S t i) cid)" + using False chan Recording assms(1) cs_when_recording_2 by auto + have step_j: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis Suc_eq_plus1 Suc_le_eq assms(1) distributed_system.step_Suc distributed_system_axioms computation.no_change_if_ge_length_t computation_axioms le_add1 not_less_eq_eq snap_p(1) snap_p(2)) + then have "map Msg (fst (cs (S t j) cid)) @ takeWhile ((\) Marker) (msgs (S t j) cid) + = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (j+1)) cid)" + proof - + have o: "~ regular_event (t ! j) \ occurs_on (t ! j) = p" + by (metis (no_types, hide_lams) distributed_system.no_state_change_if_no_event distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(1) snap_p(2) step_j) + then show ?thesis + using chan snapshot_step_cs_preservation_p step_j by blast + qed + moreover have "map Msg (fst (cs final cid)) + = map Msg (fst (cs (S t (j+1)) cid)) @ takeWhile ((\) Marker) (msgs (S t (j+1)) cid)" + proof - + have "snd (cs (S t (j+1)) cid) = Recording" + proof - + have f1: "ps (S t j) p = None" + by (meson snap_p(1)) + then have f2: "j < length t" + by (metis (no_types) all_processes_snapshotted_in_final_state assms(1) final_is_s_t_len_t linorder_not_le snapshot_stable_ver_3) + have "t ! j \ RecvMarker cid q p" + using f1 by (metis (no_types) Suc_eq_plus1 assms(1) recv_marker_means_snapshotted step_j) + then show ?thesis + using f2 f1 by (meson False assms(1) chan cs_done_implies_both_snapshotted(1) cs_in_initial_state_implies_not_snapshotted cs_not_not_started_stable done_only_from_recv_marker linorder_not_le recording_state.exhaust snap_q snapshot_stable_ver_3 step_j) + qed + moreover have "j+1 < length t" + proof (rule ccontr) + assume "~ j+1 < length t" + then have "snd (cs (S t (j+1)) cid) = Done" + by (metis assms(1) cs_done le_Suc_eq less_imp_Suc_add linorder_not_le no_change_if_ge_length_t) + then show False using calculation by auto + qed + ultimately show ?thesis + using chan snap_p(2) assms final_is_s_t_len_t cs_when_recording cs_done by blast + qed + ultimately show ?thesis using to_snapshot by simp + qed + then show ?thesis using fst_cs_empty by simp + qed + next + case Done + text \msgs must be empty, and cs must also be empty\ + have fst_cs_empty: "fst (cs (S t i) cid) = []" + proof (rule ccontr) + assume "~ fst (cs (S t i) cid) = []" + then have "fst (cs (S t 0) cid) \ fst (cs (S t i) cid)" + by (metis chan assms(1) cs_not_nil_implies_postrecording_event gr_implies_not0 le0) + then have "\j. j < i \ postrecording_event t j" + using chan \fst (cs (S t i) cid) \ []\ assms(1) assms(4) cs_not_nil_implies_postrecording_event by blast + then show False using assms by auto + qed + moreover have "msgs (S t i) cid = []" + proof - + have no_marker: "Marker \ set (msgs (S t i) cid)" (is ?P) + proof (rule ccontr) + assume "~ ?P" + then have "Marker : set (msgs (S t i) cid)" by simp + then have "snd (cs (S t i) cid) \ Done" + by (metis Marker_in_channel_implies_not_done chan assms(1) nat_le_linear s_def take_all) + then show False using Done by simp + qed + have snap_both: "has_snapshotted (S t i) p \ has_snapshotted (S t i) q" + by (metis chan Done assms(1) cs_done_implies_both_snapshotted(1) cs_done_implies_has_snapshotted final_is_s_t_len_t computation.all_processes_snapshotted_in_final_state computation_axioms le_refl not_less s_def take_all) + obtain j where snap_p: "~ has_snapshotted (S t j) p" "has_snapshotted (S t (j+1)) p" + by (metis Suc_eq_plus1 assms(1) exists_snapshot_for_all_p) + have "j < i" + by (meson assms(1) not_le_imp_less snap_both snap_p(1) snapshot_stable_ver_2) + have step_j: "(S t j) \ (t ! j) \ (S t (j+1))" + by (metis Suc_eq_plus1 assms(1) distributed_system.step_Suc distributed_system_axioms computation.no_change_if_ge_length_t computation_axioms le_add1 linorder_not_less snap_p(1) snap_p(2)) + have nonreg_j: "~ regular_event (t ! j)" + by (meson distributed_system.regular_event_cannot_induce_snapshot distributed_system_axioms snap_p(1) snap_p(2) step_j) + have oc_j: "occurs_on (t ! j) = p" + using no_state_change_if_no_event snap_p(1) snap_p(2) step_j by force + have "msgs (S t i) cid = [] \ (msgs (S t i) cid \ [] \ last (msgs (S t i) cid) = Marker)" + proof - + have "msgs (S t (j+1)) cid \ [] \ last (msgs (S t (j+1)) cid) = Marker" + proof - + have "msgs (S t (j+1)) cid = msgs (S t j) cid @ [Marker]" + proof - + have "isSnapshot (t ! j) \ isRecvMarker (t ! j)" using nonregular_event nonreg_j by blast + then show ?thesis + proof (elim disjE, goal_cases) + case 1 + then have "t ! j = Snapshot p" using oc_j by auto + then show ?thesis using step_j chan by auto + next + case 2 + then obtain cid' r where RecvMarker: "t ! j = RecvMarker cid' p r" + by (metis event.collapse(5) oc_j) + have "cid \ cid'" + proof (rule ccontr) + assume "~ cid \ cid'" + then have "channel cid = channel cid'" by auto + then have "Some (p, q) = Some (r, p)" + by (metis RecvMarker RecvMarker_implies_Marker_in_set assms(1) chan computation.no_marker_if_no_snapshot computation_axioms snap_p(1) step_j) + then show False using no_self_channel chan by simp + qed + then show ?thesis using oc_j snap_p step_j chan RecvMarker by auto + qed + qed + then show ?thesis by auto + qed + moreover have "i \ length t" using assms by simp + moreover have "j+1 \ i" using `j < i` by simp + moreover have "\k. j+1 \ k \ k < i \ regular_event (t ! k) \ ~ occurs_on (t ! k) = p" (is ?R) + proof (rule ccontr) + assume "~ ?R" + then obtain k where range: "j+1 \ k" "k < i" and "regular_event (t ! k)" "occurs_on (t ! k) = p" + by blast + then have "postrecording_event t k" using snap_p + by (meson assms(1) calculation(2) le_trans linorder_not_less pre_if_regular_and_not_post prerecording_event snapshot_stable_ver_2) + then show False using assms range by auto + qed + ultimately show ?thesis + using assms(1) chan last_unchanged_or_empty_if_no_events snap_p(2) by auto + qed + then show ?thesis using no_marker last_in_set by fastforce + qed + ultimately show ?thesis + using chan Done assms(1) assms(4) final_is_s_t_len_t computation.cs_done_implies_same_snapshots computation_axioms by fastforce + qed + ultimately show "filter ((\) Marker) (msgs (S t i) cid) = map Msg (fst (cs final cid))" by simp +qed + +lemma snapshot_after_all_prerecording_events: + assumes + "trace init t final" and + "\i'. i' \ i \ ~ prerecording_event t i'" and + "\j'. j' < i \ ~ postrecording_event t j'" and + "i \ length t" + shows + "state_equal_to_snapshot (S t i) final" +proof (unfold state_equal_to_snapshot_def, rule conjI) + show "ps_equal_to_snapshot (S t i) final" + using assms ps_after_all_prerecording_events by auto + show "cs_equal_to_snapshot (S t i) final" + using assms cs_after_all_prerecording_events by auto +qed + +subsection \Obtaining the desired traces\ + +abbreviation all_prerecording_before_postrecording where + "all_prerecording_before_postrecording t \ \i. (\j. j < i \ ~ postrecording_event t j) + \ (\j. j \ i \ ~ prerecording_event t j) + \ i \ length t + \ trace init t final" + +definition count_violations :: "('a, 'b, 'c) trace \ nat" where + "count_violations t = sum (\i. if postrecording_event t i + then card {j \ {i+1.. {i+1.. 0" + by simp + +lemma count_violations_ge_0: + shows + "count_violations t \ 0" + by simp + +lemma violations_0_implies_all_subterms_0: + assumes + "count_violations t = 0" + shows + "\i \ {0.. {i+1..i. if postrecording_event t i + then card {j \ {i+1..i \ {0.. {i+1.. 0" + shows + "\i. postrecording_event t i \ card {j \ {i+1.. 0" (is ?P) +proof (rule ccontr) + assume "~ ?P" + then have "\i. ~ postrecording_event t i \ card {j \ {i+1..i. (if postrecording_event t i + then card {j \ {i+1..\i. \ postrecording_event t i \ card {j \ {i + 1.. by auto + then show "sum (\i. if postrecording_event t i + then card {j \ {i+1.. {i+1.. 0" + shows + "\j \ {i+1.. {i+1.. 0" +proof - + have "j < length t" using prerecording_event assms by auto + have "{j \ {i+1.. empty" + using Suc_eq_plus1 \j < length t\ assms(1) assms(3) less_imp_triv by auto + then show ?thesis by fastforce +qed + +lemma exists_neighboring_violation_pair: + assumes + "trace init t final" and + "count_violations t > 0" + shows + "\i j. i < j \ postrecording_event t i \ prerecording_event t j + \ (\k. (i < k \ k < j) \ ~ regular_event (t ! k)) \ j < length t" +proof - + let ?I = "{i. postrecording_event t i \ card {j \ {i+1.. 0}" + have nonempty_I: "?I \ empty" using assms exists_postrecording_violation_if_count_greater_0 by blast + have fin_I: "finite ?I" + proof (rule ccontr) + assume "~ finite ?I" + then obtain i where "i > length t" "postrecording_event t i" + by (simp add: postrecording_event) + then show False using postrecording_event by simp + qed + let ?i = "Max ?I" + have no_greater_postrec_violation: "\i. i > ?i \ ~ (postrecording_event t i \ card {j \ {i+1.. 0)" + using Max_gr_iff fin_I by blast + have post_i: "postrecording_event t ?i" + using Max_in fin_I nonempty_I by blast + have "card {j \ {?i+1.. 0" + proof - + have "?i \ ?I" + using Max_in fin_I nonempty_I by blast + then show ?thesis by simp + qed + let ?J = "{j \ {?i+1.. empty" + using `card {j \ {?i+1.. 0` exists_prerecording_violation_when_card_greater_0 + by blast + have fin_J: "finite ?J" by auto + let ?j = "Min ?J" + have pre_j: "prerecording_event t ?j" + using Min_in fin_J nonempty_J by blast + have no_smaller_prerec_violation: "\j \ {?i+1.. ~ prerecording_event t j" + using Min_less_iff fin_J by blast + have j_less_len_t: "?j < length t" + using pre_j prerecording_event by blast + have "\k. (?i < k \ k < ?j) \ ~ regular_event (t ! k)" + proof (rule allI, rule impI) + fix k + assume asm: "?i < k \ k < ?j" + then show "~ regular_event (t ! k)" + proof - + have "0_le_k": "0 \ k" by simp + have k_less_len_t: "k < length t" using j_less_len_t asm by auto + show ?thesis + proof (rule ccontr) + assume reg_event: "~ ~ regular_event (t ! k)" + then show False + proof (cases "has_snapshotted (S t k) (occurs_on (t ! k))") + case True + then have post_k: "postrecording_event t k" using reg_event k_less_len_t postrecording_event by simp + moreover have "card {j \ {k+1.. 0" + using post_k pre_j card_greater_0_if_post_after_pre asm pre_j by blast + ultimately show False using no_greater_postrec_violation asm by blast + next + case False + then have pre_k: "prerecording_event t k" using reg_event k_less_len_t prerecording_event by simp + moreover have "k \ {?i+1..k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + "trace init t final" + shows + "{k \ {0.. {0..k. k < i \ t ! k = ?t ! k" + by (metis nth_take same_begin) + then have "\k. k < i \ prerecording_event t k = prerecording_event ?t k" + proof - + have "\k. k < i \ S t k = S ?t k" using assms swap_events by simp + then show ?thesis unfolding prerecording_event using a same_length by presburger + qed + then show ?thesis by auto +qed + +lemma same_cardinality_post_swap_2: + assumes + "prerecording_event t j" and + "postrecording_event t i" and + "i < j" and + "j < length t" and + "count_violations t = Suc n" and + "\k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + "trace init t final" + shows + "card {k \ {i.. {i.. {i..k. i \ k \ k < j \ ~ prerecording_event t k" + proof (rule allI, rule impI) + fix k + assume asm: "i \ k \ k < j" + then show "~ prerecording_event t k" + proof (cases "k = i") + case True + then have "postrecording_event t k" using assms by simp + then show ?thesis + by (meson computation.postrecording_event computation.prerecording_event computation_axioms) + next + case False + then have "i < k \ k < j" using asm by force + then have "~ regular_event (t ! k)" using assms by simp + then show ?thesis unfolding prerecording_event by simp + qed + qed + then have "{k \ {i.. {j.. {i.. {i.. postrecording_event ?t (i+1) + \ (\k. k > i+1 \ k < j+1 \ ~ regular_event (?t ! k))" + using assms swap_events by blast + have "\k. i+1 \ k \ k < j+1 \ ~ prerecording_event ?t k" + proof (rule allI, rule impI) + fix k + assume asm: "i+1 \ k \ k < j+1" + then show "~ prerecording_event ?t k" + proof (cases "k = i+1") + case True + then have "postrecording_event ?t k" using swap_ind by blast + then show ?thesis + by (meson computation.postrecording_event computation.prerecording_event computation_axioms) + next + case False + then have "i+1 < k \ k < j+1" using asm by linarith + then have "~ regular_event (?t ! k)" using asm assms swap_ind by blast + then show ?thesis unfolding prerecording_event by simp + qed + qed + then have "{k \ {i+1.. {i.. {i..k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + "trace init t final" + shows + "{k \ {j+1.. {j+1..k. j+1 \ k \ k < length t \ ?t ! k = t ! k" + proof (rule allI, rule impI) + fix k + assume "j+1 \ k \ k < length t" + then have "?t ! k = drop (j+1) (swap_events i j t) ! (k-(j+1))" + by (metis (no_types, lifting) Suc_eq_plus1 Suc_leI assms(4) le_add_diff_inverse nth_drop same_length) + moreover have "t ! k = drop (j+1) t ! (k-(j+1))" + using \j + 1 \ k \ k < length t\ by auto + ultimately have "drop (j+1) ?t ! (k-(j+1)) = drop (j+1) t ! (k-(j+1))" + using assms swap_identical_tails by metis + then show "?t ! k = t ! k" + using \?t ! k = drop (j + 1) ?t ! (k - (j + 1))\ \t ! k = drop (j + 1) t ! (k - (j + 1))\ by auto + qed + then have "\k. j+1 \ k \ k < length t \ prerecording_event t k = prerecording_event ?t k" + proof - + have "\k. k \ (j+1) \ S t k = S ?t k" using assms swap_events by simp + then show ?thesis unfolding prerecording_event using a by auto + qed + then have "{k \ {j+1.. {j+1..k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + "count_violations t = Suc n" and + "trace init t final" + shows + "card {k \ {i+1..k. i < k \ k < j \ ~ prerecording_event t k" + proof (rule allI, rule impI) + fix k + assume asm: "i < k \ k < j" + then show "~ prerecording_event t k" + proof - + have "~ regular_event (t ! k)" using asm assms by blast + then show ?thesis unfolding prerecording_event by simp + qed + qed + then have "{k \ {i+1.. {j.. {i+1..k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + "count_violations t = Suc n" and + "trace init t final" + shows + "card {k \ {i+1..k. i+1 < k \ k < j+1 \ ~ regular_event (?t ! k)" using assms swap_events by blast + have "\k. i+1 \ k \ k < j+1 \ ~ prerecording_event ?t k" + proof (rule allI, rule impI) + fix k + assume asm: "i+1 \ k \ k < j+1" + then show "~ prerecording_event ?t k" + proof (cases "k = i+1") + case True + then show ?thesis using postrec_ip1 + by (meson computation.postrecording_event computation.prerecording_event computation_axioms) + next + case False + then have "i+1 < k \ k < j+1" using asm by simp + then have "~ regular_event (?t ! k)" using neigh_shift by blast + then show ?thesis unfolding prerecording_event by simp + qed + qed + then have "{k \ {i+1..k. (i < k \ k < j) \ ~ regular_event (t ! k)" and + "count_violations t = Suc n" and + "trace init t final" + shows + "count_violations (swap_events i j t) = n" +proof - + let ?t = "swap_events i j t" + let ?f = "(\i. if postrecording_event t i then card {j \ {i+1..k. k < i \ postrecording_event t k = postrecording_event ?t k" + proof - + have "\k. k < i \ S t k = S ?t k" using assms swap_events by auto + then show ?thesis unfolding postrecording_event + proof - + assume a1: "\kn na es nb. \ n < na \ \ na < length es \ \ nb < n \ swap_events n na es ! nb = (es ! nb::('a, 'b, 'c) event)" + by (metis (no_types) nth_take swap_identical_heads) + then have "\ nn < i \ \ nn < length t \ \ nn < length (swap_events i j t) \ \ regular_event (t ! nn) \ \ regular_event (swap_events i j t ! nn) \ ps (S t nn) (occurs_on (t ! nn)) = None \ ps (S (swap_events i j t) nn) (occurs_on (swap_events i j t ! nn)) = None \ regular_event (t ! nn) \ regular_event (swap_events i j t ! nn) \ nn < length t \ nn < length (swap_events i j t) \ ps (S t nn) (occurs_on (t ! nn)) \ None \ ps (S (swap_events i j t) nn) (occurs_on (swap_events i j t ! nn)) \ None" + using a1 by (metis (no_types) assms(3) assms(4) swap_identical_length) } + then show "\n regular_event (t ! n) \ ps (S t n) (occurs_on (t ! n)) \ None) = (n < length (swap_events i j t) \ regular_event (swap_events i j t ! n) \ ps (S (swap_events i j t) n) (occurs_on (swap_events i j t ! n)) \ None)" + by (metis (no_types)) + qed + qed + have same_postrec_suffix: "\k. k \ j+1 \ postrecording_event t k = postrecording_event ?t k" + proof - + have post_equal_states: "\k. k \ j+1 \ S t k = S ?t k" using assms swap_events by presburger + show ?thesis + proof (rule allI, rule impI) + fix k + assume "j+1 \ k" + then show "postrecording_event t k = postrecording_event ?t k" + proof (cases "k < length t") + case False + then have "~ postrecording_event t k" using postrecording_event by simp + moreover have "~ postrecording_event ?t k" + using postrecording_event swap_identical_length False assms by metis + ultimately show ?thesis by simp + next + case True + then show "postrecording_event t k = postrecording_event ?t k" + using post_equal_states + proof - + assume a1: "\k\j + 1. S t k = S (swap_events i j t) k" + assume a2: "k < length t" + have f3: "length t = length (swap_events i j t)" + using assms(3) assms(4) swap_identical_length by blast + have f4: "k - (j + 1) + (j + 1) = k" + using \j + 1 \ k\ le_add_diff_inverse2 by blast + have "drop (j + 1) t = drop (j + 1) (swap_events i j t)" + using assms(3) assms(4) swap_identical_tails by blast + then have "swap_events i j t ! k = t ! k" + using f4 f3 a2 by (metis (no_types) drop_drop hd_drop_conv_nth) + then show ?thesis + using f3 a1 \j + 1 \ k\ postrecording_event by presburger + qed + qed + qed + qed + + have sum_decomp_f: "sum ?f {0..l. 0 \ l \ l < i \ ?f l = ?f' l" + proof (rule allI, rule impI) + fix l + assume "0 \ l \ l < i" + then have "l < i" by simp + show "?f l = ?f' l" + proof (cases "postrecording_event t l") + case True + let ?G = "{k \ {l+1.. (?B \ ?C)" using assms `l < i` by auto + then have "card ?G = card (?A \ (?B \ ?C))" by simp + also have "card (?A \ (?B \ ?C)) = card ?A + card (?B \ ?C)" + proof - + have "?A \ (?B \ ?C) = {}" using `l < i` assms by auto + then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal) + qed + also have "card ?A + card (?B \ ?C) = card ?A + card ?B + card ?C" + proof - + have "?B \ ?C = {}" by auto + then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal) + qed + finally show ?thesis by simp + qed + have card_G': "card ?G' = card ?A' + card ?B' + card ?C'" + proof - + have "?G' = ?A' \ (?B' \ ?C')" using assms `l < i` by auto + then have "card ?G' = card (?A' \ (?B' \ ?C'))" by simp + also have "card (?A' \ (?B' \ ?C')) = card ?A' + card (?B' \ ?C')" + proof - + have "?A' \ (?B' \ ?C') = {}" using `l < i` assms by auto + then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal) + qed + also have "card ?A' + card (?B' \ ?C') = card ?A' + card ?B' + card ?C'" + proof - + have "?B' \ ?C' = {}" by auto + then show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal) + qed + finally show ?thesis by simp + qed + have "card ?G = card ?G'" + proof - + have "card ?A = card ?A'" + proof - + have "{k \ {0.. {0..l. i+2 \ l \ l < j+1 \ ?f l = ?f' l" + proof (rule allI, rule impI) + fix l + assume asm: "i+2 \ l \ l < j+1" + have "?f l = 0" + proof (cases "l = j") + case True + then have "~ postrecording_event t l" + using assms(1) postrecording_event prerecording_event by auto + then show ?thesis by simp + next + case False + then have "i < l \ l < j" using assms asm by simp + then have "~ regular_event (t ! l)" using assms by blast + then have "~ postrecording_event t l" unfolding postrecording_event by simp + then show ?thesis by simp + qed + moreover have "?f' l = 0" + proof - + have "\k. i+1 < k \ k < j+1 \ ~ regular_event (?t ! k)" using assms swap_events by blast + then have "~ regular_event (?t ! l)" using asm by simp + then have "~ postrecording_event ?t l" unfolding postrecording_event by simp + then show ?thesis by simp + qed + ultimately show "?f l = ?f' l" by simp + qed + then show ?thesis using sum_eq_if_same_subterms by simp + qed + + moreover have "sum ?f {i.. ?B" using assms by auto + moreover have "?A \ ?B = {}" by auto + ultimately show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal) + qed + have card_G': "card ?G' = card ?A' + card ?B'" + proof - + have "?G' = ?A' \ ?B'" using assms by auto + moreover have "?A' \ ?B' = {}" by auto + ultimately show ?thesis by (simp add: card_Un_disjoint disjoint_iff_not_equal) + qed + have "card ?G = card ?G' + 1" + proof - + have "card ?A = card ?A' + 1" + proof - + have "card ?A = 1" using assms card_ip1_to_j_is_1_in_normal_events by blast + moreover have "card ?A' = 0" using assms card_ip1_to_j_is_0_in_swapped_events by force + ultimately show ?thesis by algebra + qed + moreover have "card ?B = card ?B'" using assms same_cardinality_post_swap_3 by force + ultimately show ?thesis using card_G card_G' by presburger + qed + moreover have "card ?G = ?f i" using pi by simp + moreover have "card ?G' = ?f' (i+1)" using pip1 by simp + ultimately show ?thesis by argo + qed + ultimately show ?thesis by auto + qed + + ultimately show ?thesis using sum_decomp_f sum_decomp_f' by linarith + qed + + have suffix_sum: "sum ?f {j+1..l. l > j \ ?f l = ?f' l" + proof (rule allI, rule impI) + fix l + assume "l > j" + then show "?f l = ?f' l" + proof (cases "postrecording_event t l") + case True + let ?G = "{k \ {l+1.. j` by fastforce + then show ?thesis by simp + qed + moreover have "postrecording_event ?t l" using True same_postrec_suffix `l > j` by simp + moreover have "length ?t = length t" using assms(3) assms(4) by fastforce + ultimately show ?thesis using True by presburger + next + case False + then have "~ postrecording_event ?t l" using same_postrec_suffix `l > j` by simp + then show ?thesis using False by simp + qed + qed + then have "\k. j+1 \ k \ k < length t \ ?f k = ?f' k" + using discrete by blast + moreover have "length t = length ?t" + using assms(3) assms(4) swap_identical_length by blast + ultimately show ?thesis by (blast intro:sum_eq_if_same_subterms) + qed + have "sum ?f {0..t'. perm t' t + \ all_prerecording_before_postrecording t'" +using assms proof (induct "count_violations t" arbitrary: t) + case 0 + then show ?case + proof (cases "\i. prerecording_event t i") + case False + then have "\j. ~ prerecording_event t j" by auto + then have "\j. j \ 0 \ ~ postrecording_event t j" + using "0.prems" init_is_s_t_0 no_initial_process_snapshot postrecording_event by auto + moreover have "\j. j > 0 \ ~ prerecording_event t j" using False by auto + moreover have "length t > 0" + by (metis "0.prems" all_processes_snapshotted_in_final_state length_greater_0_conv no_initial_process_snapshot tr_init trace_and_start_determines_end) + ultimately show ?thesis using "0.prems" False by auto + next + case True + let ?Is = "{i. prerecording_event t i}" + have "?Is \ empty" + by (simp add: True) + moreover have fin_Is: "finite ?Is" + proof (rule ccontr) + assume "~ finite ?Is" + then obtain i where "i > length t" "prerecording_event t i" + by (simp add: prerecording_event) + then show False using prerecording_event by auto + qed + let ?i = "Max ?Is" + have pi: "prerecording_event t ?i" + using Max_in calculation fin_Is by blast + have "?i < length t" + proof (rule ccontr) + assume "~ ?i < length t" + then show False + using calculation fin_Is computation.prerecording_event computation_axioms by force + qed + moreover have "\j. j \ ?i+1 \ ~ prerecording_event t j" + proof - + have "\j. j > ?i \ ~ prerecording_event t j" + using Max_less_iff fin_Is by auto + then show ?thesis by auto + qed + moreover have "\j. j < ?i+1 \ ~ postrecording_event t j" + proof - + have "\j. j \ ?i \ ~ postrecording_event t j" + proof (rule allI, rule impI, rule ccontr) + fix j + assume "j \ ?i" "~ ~ postrecording_event t j" + then have "j < ?i" + by (metis add_diff_inverse_nat dual_order.antisym le_add1 pi postrecording_event prerecording_event) + then have "count_violations t > 0" + proof - + have "(if postrecording_event t j + then card {l \ {j+1.. {j+1.. {j+1.. 0" + proof - + have "j + 1 \ ?i \ ?i < length t" + using \Max {i. prerecording_event t i} < length t\ \j < Max {i. prerecording_event t i}\ discrete by blast + moreover have "prerecording_event t ?i" using pi by simp + ultimately have "{l \ {j+1.. empty" by fastforce + then show ?thesis by fastforce + qed + ultimately show ?thesis + by (metis (no_types, lifting) violations_0_implies_all_subterms_0 \Max {i. prerecording_event t i} < length t\ \j < Max {i. prerecording_event t i}\ atLeastLessThan_iff less_trans linorder_not_le neq0_conv) + qed + then show False using "0" by simp + qed + then show ?thesis by auto + qed + moreover have "?i+1 \ length t" + using calculation(2) discrete by blast + ultimately show ?thesis using "0.prems" by blast + qed +next + case (Suc n) + then obtain i j where ind: "postrecording_event t i" "prerecording_event t j" + "\k. (i < k \ k < j) \ ~ regular_event (t ! k)" + "i < j" "j < length t" using exists_neighboring_violation_pair Suc by force + then have "trace init (swap_events i j t) final + \ (\k. k \ j + 1 \ S (swap_events i j t) k = S t k) + \ (\k. k \ i \ S (swap_events i j t) k = S t k)" + using Suc swap_events by presburger + moreover have "perm (swap_events i j t) t" using swap_events_perm ind by blast + moreover have "count_violations (swap_events i j t) = n" + using count_violations_swap Suc ind by simp + ultimately show ?case using Suc.hyps by blast +qed + +theorem snapshot_algorithm_is_correct: + assumes + "trace init t final" + shows + "\t' i. trace init t' final \ perm t' t + \ state_equal_to_snapshot (S t' i) final \ i \ length t'" +proof - + obtain t' where "perm t' t" and + "all_prerecording_before_postrecording t'" + using assms desired_trace_always_exists by blast + then show ?thesis using snapshot_after_all_prerecording_events + by blast +qed + +subsection \Stable property detection\ + +text \Finally, we show that the computed snapshot is indeed +suitable for stable property detection, as claimed in~\cite{chandy}.\ + +definition stable where + "stable p \ (\c. p c \ (\t c'. trace c t c' \ p c'))" + +lemma has_snapshot_stable: + assumes + "trace init t final" + shows + "stable (\c. has_snapshotted c p)" + using snapshot_stable stable_def by auto + +definition some_snapshot_state where + "some_snapshot_state t \ + SOME (t', i). trace init t final + \ trace init t' final \ perm t' t + \ state_equal_to_snapshot (S t' i) final" + +lemma split_S: + assumes + "trace init t final" + shows + "trace (S t i) (drop i t) final" +proof - + have "t = take i t @ drop i t" by simp + then show ?thesis + by (metis split_trace assms exists_trace_for_any_i + trace_and_start_determines_end) +qed + +theorem Stable_Property_Detection: + assumes + "stable p" and + "trace init t final" and + "(t', i) = some_snapshot_state t" and + "p (S t' i)" + shows + "p final" +proof - + have "\t' i. trace init t final + \ trace init t' final \ perm t' t + \ state_equal_to_snapshot (S t' i) final" + using snapshot_algorithm_is_correct assms(2) by blast + then have "trace init t' final" + using assms + unfolding some_snapshot_state_def + by (metis (lifting) case_prodD case_prodI someI_ex) + then show ?thesis + using assms stable_def split_S by metis +qed + +end (* locale computation *) + +end (* theory Snapshot *) diff --git a/thys/Chandy_Lamport/Swap.thy b/thys/Chandy_Lamport/Swap.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Swap.thy @@ -0,0 +1,1553 @@ +section \Swap lemmas\ + +text \\ + +theory Swap + imports + Distributed_System + +begin + +context distributed_system + +begin + +lemma swap_msgs_Trans_Trans: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isTrans ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain u u' where "ev = Trans ?p u u'" + by (metis assms(3) event.collapse(1)) + obtain u'' u''' where "ev' = Trans ?q u'' u'''" + by (metis assms(4) event.collapse(1)) + then have "msgs d' i = msgs d i" + by (metis Trans_msg assms(1) assms(3) assms(4) assms(5)) + then have "msgs e i = msgs e' i" + using Trans_msg assms(2) assms(3) assms(4) assms(6) by auto + then show ?thesis by blast +qed + +lemma swap_msgs_Send_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Send_ev: "ev = Send i' ?p r u u' m" + by (metis assms(3) event.collapse(2)) + obtain i'' s u'' u''' m' where Send_ev': "ev' = Send i'' ?q s u'' u''' m'" + by (metis assms(4) event.collapse(2)) + have "i' \ i''" + by (metis (mono_tags, lifting) \ev = Send i' (occurs_on ev) r u u' m\ \ev' = Send i'' (occurs_on ev') s u'' u''' m'\ assms(1) assms(2) assms(7) can_occur_def event.simps(27) happen_implies_can_occur option.simps(1) prod.simps(1)) + then show ?thesis + proof (cases "i = i' \ i = i''") + case True + then show ?thesis + proof (elim disjE) + assume "i = i'" + then have "msgs d i = msgs c i @ [Msg m]" + by (metis \ev = Send i' (occurs_on ev) r u u' m\ assms(1) next_send) + moreover have "msgs e i = msgs d i" + by (metis \ev' = Send i'' (occurs_on ev') s u'' u''' m'\ \i = i'\ \i' \ i''\ assms(2) assms(4) event.sel(8) msgs_unchanged_for_other_is regular_event) + moreover have "msgs d' i = msgs c i" + by (metis \ev' = Send i'' (occurs_on ev') s u'' u''' m'\ \i = i'\ \i' \ i''\ assms(4) assms(5) event.sel(8) msgs_unchanged_for_other_is regular_event) + moreover have "msgs e' i = msgs d' i @ [Msg m]" + by (metis \ev = Send i' (occurs_on ev) r u u' m\ \i = i'\ assms(6) next_send) + ultimately show ?thesis by simp + next + assume "i = i''" + then have "msgs d i = msgs c i" + by (metis Send_ev \i' \ i''\ assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + moreover have "msgs e i = msgs d i @ [Msg m']" + by (metis Send_ev' \i = i''\ assms(2) next_send) + moreover have "msgs d' i = msgs c i @ [Msg m']" + by (metis Send_ev' \i = i''\ assms(5) next_send) + moreover have "msgs e' i = msgs d' i" + by (metis Send_ev \i = i''\ \i' \ i''\ assms(3) assms(6) event.sel(8) msgs_unchanged_for_other_is regular_event) + ultimately show ?thesis by simp + qed + next + case False + then have "msgs e i = msgs d i" using Send_ev' assms + by (metis event.sel(8) msgs_unchanged_for_other_is regular_event) + also have "... = msgs c i" + by (metis False Send_ev assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + also have "... = msgs d' i" + by (metis (no_types, hide_lams) \msgs d i = msgs c i\ assms(2) assms(4) assms(5) calculation regular_event same_messages_imply_same_resulting_messages) + also have "... = msgs e' i" + by (metis (no_types, hide_lams) \msgs c i = msgs d' i\ \msgs d i = msgs c i\ assms(1) assms(3) assms(6) regular_event same_messages_imply_same_resulting_messages) + finally show ?thesis by simp + qed +qed + +lemma swap_msgs_Recv_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Recv_ev: "ev = Recv i' ?p r u u' m" + by (metis assms(3) event.collapse(3)) + obtain i'' s u'' u''' m' where Recv_ev': "ev' = Recv i'' ?q s u'' u''' m'" + by (metis assms(4) event.collapse(3)) + have "i' \ i''" + by (metis Recv_ev Recv_ev' assms(1) assms(2) assms(7) can_occur_Recv happen_implies_can_occur option.simps(1) prod.simps(1)) + show ?thesis + proof (cases "i = i' \ i = i''") + case True + then show ?thesis + proof (elim disjE) + assume "i = i'" + then have "Msg m # msgs d i = msgs c i" using Recv_ev assms by (metis next_recv) + moreover have "msgs e i = msgs d i" + by (metis Recv_ev' \i = i'\ \i' \ i''\ assms(2) assms(4) event.sel(9) msgs_unchanged_for_other_is regular_event) + moreover have "msgs d' i = msgs c i" + by (metis Recv_ev' \i = i'\ \i' \ i''\ assms(4) assms(5) event.sel(9) msgs_unchanged_for_other_is regular_event) + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv_ev \i = i'\ assms(6) next_recv) + ultimately show ?thesis by (metis list.inject) + next + assume "i = i''" + then have "msgs d i = msgs c i" + by (metis Recv_ev \i' \ i''\ assms(1) assms(3) event.sel(9) msgs_unchanged_for_other_is regular_event) + moreover have "Msg m' # msgs e i = msgs d i" + by (metis Recv_ev' \i = i''\ assms(2) next_recv) + moreover have "Msg m' # msgs d' i = msgs c i" + by (metis Recv_ev' \i = i''\ assms(5) next_recv) + moreover have "msgs e' i = msgs d' i" + by (metis Recv_ev \i = i''\ \i' \ i''\ assms(3) assms(6) event.sel(9) msgs_unchanged_for_other_is regular_event) + ultimately show ?thesis by (metis list.inject) + qed + next + case False + then have "msgs e i = msgs d i" + by (metis Recv_ev' assms(2) assms(4) event.sel(9) msgs_unchanged_for_other_is regular_event) + also have "... = msgs c i" + by (metis False Recv_ev assms(1) assms(3) event.sel(9) msgs_unchanged_for_other_is regular_event) + also have "... = msgs d' i" + by (metis (no_types, hide_lams) \msgs d i = msgs c i\ assms(2) assms(4) assms(5) calculation regular_event same_messages_imply_same_resulting_messages) + also have "... = msgs e' i" + by (metis (no_types, lifting) \msgs c i = msgs d' i\ \msgs d i = msgs c i\ assms(1) assms(3) assms(6) regular_event same_messages_imply_same_resulting_messages) + finally show ?thesis by simp + qed +qed + +lemma swap_msgs_Send_Trans: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Send: "ev = Send i' ?p r u u' m" + by (metis assms(3) event.collapse(2)) + obtain u'' u''' where Trans: "ev' = Trans ?q u'' u'''" + by (metis assms(4) event.collapse(1)) + show ?thesis + proof (cases "i = i'") + case True + then have "msgs d i = msgs c i @ [Msg m]" + by (metis Send assms(1) next_send) + moreover have "msgs e i = msgs d i" + using Trans_msg assms(2) assms(4) by auto + moreover have "msgs d' i = msgs c i" + using Trans_msg assms(4) assms(5) by auto + moreover have "msgs e' i = msgs d' i @ [Msg m]" + by (metis Send True assms(6) next_send) + ultimately show ?thesis by simp + next + case False + then have "msgs e i = msgs d i" + using Trans_msg assms(2) assms(4) by auto + also have "... = msgs c i" + by (metis False Send assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + also have "... = msgs d' i" + using Trans_msg assms(4) assms(5) by blast + also have "... = msgs e' i" + by (metis (no_types, lifting) \msgs c i = msgs d' i\ \msgs d i = msgs c i\ assms(1) assms(3) assms(6) regular_event same_messages_imply_same_resulting_messages) + finally show ?thesis by simp + qed +qed + +lemma swap_msgs_Trans_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isTrans ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_msgs_Send_Trans by auto + +lemma swap_msgs_Recv_Trans: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Recv: "ev = Recv i' ?p r u u' m" + by (metis assms(3) event.collapse(3)) + obtain u'' u''' where Trans: "ev' = Trans ?q u'' u'''" + by (metis assms(4) event.collapse(1)) + show ?thesis + proof (cases "i = i'") + case True + then have "Msg m # msgs d i = msgs c i" + by (metis Recv assms(1) next_recv) + moreover have "msgs e i = msgs d i" + using Trans_msg assms(2) assms(4) by auto + moreover have "msgs d' i = msgs c i" + using Trans_msg assms(4) assms(5) by auto + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv True assms(6) next_recv) + ultimately show ?thesis by (metis list.inject) + next + case False + then have "msgs e i = msgs d i" + using Trans_msg assms(2) assms(4) by auto + also have "... = msgs c i" + by (metis False Recv assms(1) assms(3) event.sel(9) msgs_unchanged_for_other_is regular_event) + also have "... = msgs d' i" + using Trans_msg assms(4) assms(5) by blast + also have "... = msgs e' i" + by (metis False Recv assms(6) next_recv) + finally show ?thesis by simp + qed +qed + +lemma swap_msgs_Trans_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isTrans ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_msgs_Recv_Trans by auto + +lemma swap_msgs_Send_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Send: "ev = Send i' ?p r u u' m" + by (metis assms(3) event.collapse(2)) + obtain i'' s u'' u''' m' where Recv: "ev' = Recv i'' ?q s u'' u''' m'" + by (metis assms(4) event.collapse(3)) + show ?thesis + proof (cases "i = i'"; cases "i = i''", goal_cases) + case 1 + then have "msgs e' i = msgs d' i @ [Msg m]" + by (metis Send assms(6) next_send) + moreover have "Msg m' # msgs d' i = msgs c i" + by (metis "1"(2) Recv assms(5) next_recv) + moreover have "msgs d i = msgs c i @ [Msg m]" + by (metis "1"(1) Send assms(1) next_send) + moreover have "Msg m' # msgs e i = msgs d i" + by (metis "1"(2) Recv assms(2) next_recv) + ultimately show ?thesis + by (metis list.sel(2) list.sel(3) not_Cons_self2 tl_append2) + next + case 2 + then have "msgs d i = msgs c i @ [Msg m]" + by (metis Send assms(1) next_send) + moreover have "msgs e i = msgs d i" + by (metis "2"(2) Recv assms(2) assms(4) event.sel(9) msgs_unchanged_for_other_is regular_event) + moreover have "msgs d' i = msgs c i" + by (metis "2"(2) Recv assms(4) assms(5) event.sel(9) msgs_unchanged_for_other_is regular_event) + moreover have "msgs e' i = msgs d' i @ [Msg m]" + by (metis Send 2(1) assms(6) next_send) + ultimately show ?thesis by simp + next + assume 3: "i \ i'" "i = i''" + then have "msgs d i = msgs c i" + by (metis Send assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + moreover have "Msg m' # msgs e i = msgs d i" using 3 Recv assms by (metis next_recv) + moreover have "Msg m' # msgs d' i = msgs c i" + by (metis "3"(2) Recv assms(5) next_recv) + moreover have "msgs e' i = msgs d' i" + by (metis "3"(1) Send assms(6) next_send) + ultimately show ?thesis by (metis list.inject) + next + assume 4: "i \ i'" "i \ i''" + then have "msgs e i = msgs d i" + by (metis Recv assms(2) assms(4) event.sel(9) msgs_unchanged_for_other_is regular_event) + also have "... = msgs c i" + by (metis "4"(1) Send assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + also have "... = msgs d' i" + by (metis "4"(2) Recv assms(5) next_recv) + also have "... = msgs e' i" + by (metis "4"(1) Send assms(6) next_send) + finally show ?thesis by simp + qed +qed + +lemma swap_msgs_Recv_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_msgs_Send_Recv by auto + +lemma same_cs_implies_same_resulting_cs: + assumes + "cs c i = cs d i" + "c \ ev \ c'" and + "d \ ev \ d'" and + "regular_event ev" + shows + "cs c' i = cs d' i" +proof - + have "isTrans ev \ isSend ev \ isRecv ev" using assms by simp + then show ?thesis + proof (elim disjE) + assume "isTrans ev" + then show ?thesis + by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) event.distinct_disc(4) no_cs_change_if_no_event) + next + assume "isSend ev" + then show ?thesis + by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) event.distinct_disc(10) no_cs_change_if_no_event) + next + assume "isRecv ev" + then obtain i' r s u u' m where Recv: "ev = Recv i' r s u u' m" + by (meson isRecv_def) + then show ?thesis + proof (cases "i' = i") + case True + with assms Recv show ?thesis by (cases "snd (cs c i) = Recording", auto) + next + case False + then show ?thesis using assms Recv by simp + qed + qed +qed + +lemma regular_event_implies_same_channel_snapshot_Recv_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "cs e i = cs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Recv_ev: "ev = Recv i' ?p r u u' m" + by (metis assms(3) event.collapse(3)) + obtain i'' s u'' u''' m' where Recv_ev': "ev' = Recv i'' ?q s u'' u''' m'" + by (metis assms(4) event.collapse(3)) + have "i' \ i''" + by (metis Recv_ev Recv_ev' assms(1) assms(5) assms(7) can_occur_Recv happen_implies_can_occur option.simps(1) prod.simps(1)) + show ?thesis + proof (cases "i = i' \ i = i''") + case True + then show ?thesis + proof (elim disjE) + assume "i = i'" + then have "cs d' i = cs c i" + using assms(4) assms(5) assms(7) no_cs_change_if_no_event + by (metis Recv_ev' \i' \ i''\ event.sel(9) regular_event) + then have "cs e' i = cs d i" + using assms(1) assms(3) assms(6) distributed_system.same_cs_implies_same_resulting_cs distributed_system_axioms regular_event by blast + then have "cs d i = cs e i" + by (metis Recv_ev' \i = i'\ \i' \ i''\ assms(2) assms(4) event.sel(9) no_cs_change_if_no_event regular_event) + then show ?thesis + by (simp add: \cs e' i = cs d i\) + next + assume "i = i''" + then have "cs d i = cs c i" + by (metis Recv_ev \i' \ i''\ assms(1) assms(3) event.sel(9) no_cs_change_if_no_event regular_event) + then have "cs e i = cs d' i" + using assms(2) assms(4) assms(5) regular_event same_cs_implies_same_resulting_cs by blast + then have "cs d' i = cs e' i" + by (metis Recv_ev \i = i''\ \i' \ i''\ assms(3) assms(6) event.sel(9) no_cs_change_if_no_event regular_event) + then show ?thesis + by (simp add: \cs e i = cs d' i\) + qed + next + case False + then show ?thesis + by (metis Recv_ev Recv_ev' assms(1) assms(2) assms(5) assms(6) next_recv) + qed +qed + +lemma regular_event_implies_same_channel_snapshot_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "~ isRecv ev" and + "regular_event ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "cs e i = cs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' s u'' u''' m' where Recv: "ev' = Recv i' ?q s u'' u''' m'" + by (metis assms(5) event.collapse(3)) + show ?thesis + proof (cases "i = i'") + case True + then have "cs d i = cs c i" + using assms(1) assms(3) assms(7) no_cs_change_if_no_event `regular_event ev` `~ isRecv ev` by auto + then have "cs e i = cs d' i" + using assms(2) assms(5) assms(6) regular_event same_cs_implies_same_resulting_cs by blast + then have "cs d' i = cs e' i" + using True assms(3) assms(6) assms(7) no_cs_change_if_no_event `regular_event ev` `~ isRecv ev` by auto + then show ?thesis + by (simp add: \cs e i = cs d' i\) + next + case False + then have "cs d i = cs c i" + using assms(1) assms(3) assms(4) no_cs_change_if_no_event by auto + then have "cs d' i = cs e i" + by (metis (no_types, lifting) assms(2) assms(5) assms(6) regular_event same_cs_implies_same_resulting_cs) + then show "cs e i = cs e' i" + using assms(3) assms(4) assms(7) no_cs_change_if_no_event by auto + qed +qed + +lemma same_messages_2: + assumes + "\p. has_snapshotted c p = has_snapshotted d p" and + "msgs c i = msgs d i" and + "c \ ev \ c'" and + "d \ ev \ d'" and + "~ regular_event ev" + shows + "msgs c' i = msgs d' i" +proof (cases "channel i = None") + case True + then show ?thesis + using assms(2) assms(3) assms(4) no_msgs_change_if_no_channel by auto +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + have "isSnapshot ev \ isRecvMarker ev" + using assms(5) event.exhaust_disc by auto + then show ?thesis + proof (elim disjE) + assume "isSnapshot ev" + then obtain r where Snapshot: "ev = Snapshot r" by (meson isSnapshot_def) + then show ?thesis + proof (cases "r = p") + case True + then have "msgs c' i = msgs c i @ [Marker]" using chan Snapshot assms by simp + moreover have "msgs d' i = msgs d i @ [Marker]" using chan Snapshot assms True by simp + ultimately show ?thesis using assms by simp + next + case False + then have "msgs c' i = msgs c i" using chan Snapshot assms by simp + moreover have "msgs d' i = msgs d i" using chan Snapshot assms False by simp + ultimately show ?thesis using assms by simp + qed + next + assume "isRecvMarker ev" + then obtain i' r s where RecvMarker: "ev = RecvMarker i' r s" + by (meson isRecvMarker_def) + then show ?thesis + proof (cases "has_snapshotted c r") + case snap: True + then show ?thesis + proof (cases "i = i'") + case True + then have "Marker # msgs c' i = msgs c i" using chan RecvMarker assms snap by simp + moreover have "Marker # msgs d' i = msgs d i" using chan RecvMarker assms snap True by simp + ultimately show ?thesis using assms by (metis list.inject) + next + case False + then have "msgs d' i = msgs d i" + using RecvMarker assms(1) assms(4) snap by auto + also have "... = msgs c i" using assms by simp + also have "... = msgs c' i" + using False RecvMarker snap assms by auto + finally show ?thesis using snap by simp + qed + next + case no_snap: False + then show ?thesis + proof (cases "i = i'") + case True + then have "Marker # msgs c' i = msgs c i" using chan RecvMarker assms by simp + moreover have "Marker # msgs d' i = msgs d i" using chan RecvMarker assms True by simp + ultimately show ?thesis using assms by (metis list.inject) + next + case not_i: False + then show ?thesis + proof (cases "r = p") + case True + then have "msgs c' i = msgs c i @ [Marker]" + using no_snap RecvMarker assms True chan not_i by auto + moreover have "msgs d' i = msgs d i @ [Marker]" + proof - + have "~ has_snapshotted d r" using assms no_snap True by simp + then show ?thesis + using no_snap RecvMarker assms True chan not_i by auto + qed + ultimately show ?thesis using assms by simp + next + case False + then have "msgs c i = msgs c' i" using False RecvMarker no_snap chan assms not_i by simp + moreover have "msgs d' i = msgs d i" + proof - + have "~ has_snapshotted d r" using assms no_snap False by simp + then show ?thesis + using False RecvMarker no_snap chan assms not_i by simp + qed + ultimately show ?thesis using assms by simp + qed + qed + qed + qed +qed + +lemma same_cs_2: + assumes + "\p. has_snapshotted c p = has_snapshotted d p" and + "cs c i = cs d i" and + "c \ ev \ c'" and + "d \ ev \ d'" + shows + "cs c' i = cs d' i" +proof (cases "channel i = None") + case True + then show ?thesis + using assms(2) assms(3) assms(4) no_cs_change_if_no_channel by auto +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + then show ?thesis + proof (cases ev) + case (Snapshot r) + with assms chan show ?thesis by (cases "r = q", auto) + next + case (RecvMarker i' r s) + then show ?thesis + proof (cases "has_snapshotted c r") + case snap: True + then have sdr: "has_snapshotted d r" using assms by auto + then show ?thesis + proof (cases "i = i'") + case True + then have "cs c' i = (fst (cs c i), Done)" + using RecvMarker assms(3) next_recv_marker by blast + also have "... = cs d' i" + using RecvMarker True assms(2) assms(4) by auto + finally show ?thesis using True by simp + next + case False + then have "cs c' i = cs c i" using RecvMarker assms snap by auto + also have "... = cs d' i" using RecvMarker assms snap sdr False by auto + finally show ?thesis by simp + qed + next + case no_snap: False + then have nsdr: "~ has_snapshotted d r" using assms by blast + show ?thesis + proof (cases "i = i'") + case True + then have "cs c' i = (fst (cs c i), Done)" + using RecvMarker assms(3) next_recv_marker by blast + also have "... = cs d' i" + using RecvMarker True assms(2) assms(4) by auto + finally show ?thesis using True by simp + next + case not_i: False + with assms RecvMarker chan no_snap show ?thesis by (cases "r = q", auto) + qed + qed + next + case (Trans r u u') + then show ?thesis + by (metis assms(2) assms(3) assms(4) event.disc(1) regular_event same_cs_implies_same_resulting_cs) + next + case (Send i' r s u u' m) + then show ?thesis + by (metis assms(2) assms(3) assms(4) event.disc(7) regular_event same_cs_implies_same_resulting_cs) + next + case (Recv i' r s u u' m) + then show ?thesis + by (metis assms(2) assms(3) assms(4) event.disc(13) regular_event same_cs_implies_same_resulting_cs) + qed +qed + +lemma swap_Snapshot_Trans: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSnapshot ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof - + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + have "ev = Snapshot ?p" + by (metis assms(3) event.collapse(4)) + obtain u'' u''' where "ev' = Trans ?q u'' u'''" + by (metis assms(4) event.collapse(1)) + have "msgs c i = msgs d' i" + using Trans_msg assms(4) assms(5) by blast + then have "msgs e' i = msgs d i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d' p" + using assms(4) assms(5) regular_event_preserves_process_snapshots by auto + moreover have "msgs c i = msgs d' i" using `msgs c i = msgs d' i` by auto + moreover have "c \ ev \ d" using assms by auto + moreover have "d' \ ev \ e'" using assms by auto + moreover have "~ regular_event ev" using assms by auto + ultimately show ?thesis by (blast intro: same_messages_2[symmetric]) + qed + then have "msgs d i = msgs e i" + using Trans_msg assms(2) assms(4) by blast + then show ?thesis + by (simp add: \msgs e' i = msgs d i\) +qed + +lemma swap_msgs_Trans_RecvMarker: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecvMarker ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e' i = msgs e i" +proof - + have nr: "~ regular_event ev" + using assms(3) nonregular_event by blast + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r where RecvMarker: "ev = RecvMarker i' ?p r" + by (metis assms(3) event.collapse(5)) + obtain u'' u''' where Trans: "ev' = Trans ?q u'' u'''" + by (metis assms(4) event.collapse(1)) + have "msgs c i = msgs d' i" + using Trans_msg assms(4) assms(5) by blast + then have "msgs e' i = msgs d i" + proof - + have "\p. has_snapshotted d' p = has_snapshotted c p" + using assms(4) assms(5) regular_event_preserves_process_snapshots by auto + moreover have "~ regular_event ev" using assms by auto + moreover have "\n. msgs d' n = msgs c n" (* why does he need this assumption? *) + by (metis Trans assms(5) local.next.simps(3)) + ultimately show ?thesis + using assms(1) assms(6) same_messages_2 by blast + qed + thm same_messages_2 + then have "msgs d i = msgs e i" + using Trans_msg assms(2) assms(4) by blast + then show ?thesis + by (simp add: \msgs e' i = msgs d i\) +qed + +lemma swap_Trans_Snapshot: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isTrans ev" and + "isSnapshot ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_Snapshot_Trans by auto + +lemma swap_Send_Snapshot: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isSnapshot ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_msgs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Send: "ev = Send i' ?p r u u' m" + by (metis assms(3) event.collapse(2)) + have Snapshot: "ev' = Snapshot ?q" + by (metis assms(4) event.collapse(4)) + show ?thesis + proof (cases "i = i'"; cases "p = ?q") + assume asm: "i = i'" "p = ?q" + then have "?p = p" + proof - + have "channel i' = Some (p, q)" using chan asm by simp + then show ?thesis using assms can_occur_def Send chan + by (metis (mono_tags, lifting) event.simps(27) happen_implies_can_occur option.inject prod.inject) + qed + then show ?thesis using assms asm by simp + next + assume "i = i'" "p \ ?q" + then have "msgs d i = msgs c i @ [Msg m]" + by (metis Send assms(1) next_send) + moreover have "msgs e i = msgs d i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(2) chan next_snapshot option.inject) + moreover have "msgs d' i = msgs c i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(5) chan next_snapshot option.inject) + moreover have "msgs e' i = msgs d' i @ [Msg m]" + by (metis Send \i = i'\ assms(6) next_send) + ultimately show ?thesis by simp + next + assume asm: "i \ i'" "p = ?q" + then have "msgs d i = msgs c i" + by (metis Send assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + moreover have "msgs e i = msgs c i @ [Marker]" + by (metis (full_types) Snapshot asm(2) assms(2) calculation chan next_snapshot) + moreover have "msgs d' i = msgs c i @ [Marker]" + by (metis (full_types) Snapshot asm(2) assms(5) chan next_snapshot) + moreover have "msgs e' i = msgs d' i" + by (metis Send asm(1) assms(6) next_send) + ultimately show ?thesis by simp + next + assume "i \ i'" "p \ ?q" + then have "msgs c i = msgs d i" + by (metis Send assms(1) assms(3) event.sel(8) msgs_unchanged_for_other_is regular_event) + then have "msgs e i = msgs d' i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(2,5) chan next_snapshot option.inject) + then show ?thesis + by (metis Send \i \ i'\ assms(6) next_send) + qed +qed + +lemma swap_Snapshot_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSnapshot ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_Send_Snapshot by auto + +lemma swap_Recv_Snapshot: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isSnapshot ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_msgs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Recv: "ev = Recv i' ?p r u u' m" + by (metis assms(3) event.collapse(3)) + have Snapshot: "ev' = Snapshot ?q" + by (metis assms(4) event.collapse(4)) + show ?thesis + proof (cases "i = i'"; cases "p = ?q") + assume "i = i'" "p = ?q" + then have "Msg m # msgs d i = msgs c i" + by (metis Recv assms(1) next_recv) + moreover have "msgs e i = msgs d i @ [Marker]" + by (metis (full_types) Snapshot \p = occurs_on ev'\ assms(2) chan next_snapshot) + moreover have "msgs d' i = msgs c i @ [Marker]" + by (metis (full_types) Snapshot \p = occurs_on ev'\ assms(5) chan next_snapshot) + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv \i = i'\ assms(6) next_recv) + ultimately show ?thesis + by (metis list.sel(3) neq_Nil_conv tl_append2) + next + assume "i = i'" "p \ ?q" + then have "Msg m # msgs d i = msgs c i" + by (metis Recv assms(1) next_recv) + moreover have "msgs e i = msgs d i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(2) chan next_snapshot option.inject) + moreover have "msgs d' i = msgs c i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(5) chan next_snapshot option.inject) + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv \i = i'\ assms(6) next_recv) + ultimately show ?thesis by (metis list.inject) + next + assume "i \ i'" "p = ?q" + then have "msgs d i = msgs c i" + by (metis Recv assms(1) next_recv) + moreover have "msgs e i = msgs d i @ [Marker]" + by (metis (full_types) Snapshot \p = occurs_on ev'\ assms(2) chan next_snapshot) + moreover have "msgs d' i = msgs c i @ [Marker]" + by (metis (full_types) Snapshot \p = occurs_on ev'\ assms(5) chan next_snapshot) + moreover have "msgs e' i = msgs d' i" + by (metis Recv \i ~= i'\ assms(6) next_recv) + ultimately show ?thesis by simp + next + assume "i \ i'" "p \ ?q" + then have "msgs d i = msgs c i" + by (metis Recv assms(1) next_recv) + moreover have "msgs e i = msgs d i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(2) chan next_snapshot option.inject) + moreover have "msgs d' i = msgs c i" + by (metis Pair_inject Snapshot \p \ occurs_on ev'\ assms(5) chan next_snapshot option.inject) + moreover have "msgs e' i = msgs d' i" + by (metis Recv \i ~= i'\ assms(6) next_recv) + ultimately show ?thesis by auto + qed +qed + +lemma swap_Snapshot_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSnapshot ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_Recv_Snapshot by auto + +lemma swap_msgs_Recv_RecvMarker: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isRecvMarker ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_msgs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + obtain i' p' r u u' m where Recv: "ev = Recv i' p' r u u' m" + by (metis assms(3) event.collapse(3)) + obtain i'' q' s where RecvMarker: "ev' = RecvMarker i'' q' s" + by (metis assms(4) event.collapse(5)) + have "i' \ i''" + proof (rule ccontr) + assume "~ i' \ i''" + then have "channel i' = channel i''" by auto + then have "Some (r, p') = Some (s, q')" using assms can_occur_def Recv RecvMarker by simp + then show False using assms + by (metis Recv RecvMarker event.sel(3,5) option.inject prod.inject) + qed + then show ?thesis + proof (cases "i = i' \ i = i''") + case True + then show ?thesis + proof (elim disjE) + assume "i = i'" + then have pqrp: "(p, q) = (r, p')" + by (metis Recv assms(1) chan distributed_system.can_occur_Recv distributed_system_axioms next_recv option.inject) + then show ?thesis + proof (cases "has_snapshotted c q'") + case snap: True + then have "Msg m # msgs d i = msgs c i" + by (metis Recv \i = i'\ assms(1) next_recv) + moreover have "msgs c i = msgs d' i" + using RecvMarker \i = i'\ \i' \ i''\ assms(5) msgs_unchanged_if_snapshotted_RecvMarker_for_other_is snap by blast + moreover have "msgs d i = msgs e i" + using RecvMarker \i = i'\ \i' \ i''\ assms(1) assms(2) snap snapshot_state_unchanged by auto + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv \i = i'\ assms(6) next_recv) + ultimately show ?thesis by (metis list.inject) + next + case no_snap: False + then have msgs_d: "Msg m # msgs d i = msgs c i" + by (metis Recv \i = i'\ assms(1) next_recv) + then show ?thesis + proof (cases "q' = r") + case True + then have "msgs d' i = msgs c i @ [Marker]" + proof - + have "channel i = Some (q', q)" + using True chan pqrp by blast + then show ?thesis using RecvMarker assms no_snap + by (simp add: no_snap \i = i'\ \i' \ i''\) + qed + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv \i = i'\ assms(6) next_recv) + moreover have "msgs e i = msgs d i @ [Marker]" + proof - + have "ps d q' = ps c q'" + using assms(1) assms(7) no_state_change_if_no_event RecvMarker by auto + then show ?thesis + using RecvMarker \i = i'\ \i' \ i''\ assms True chan no_snap pqrp by simp + qed + ultimately show ?thesis using msgs_d + by (metis append_self_conv2 list.inject list.sel(3) message.distinct(1) tl_append2) + next + case False + then have "msgs e i = msgs d i" + proof - + have "~ has_snapshotted d q'" + using assms(1) assms(7) no_snap no_state_change_if_no_event RecvMarker by auto + moreover have "\r. channel i = Some (q', r)" using chan False pqrp by auto + moreover have "i \ i''" using `i = i'` `i' \ i''` by simp + ultimately show ?thesis using RecvMarker assms by simp + qed + moreover have "msgs d' i = msgs c i" + proof - + have "\r. channel i = Some (q', r)" + using False chan pqrp by auto + moreover have "i \ i''" using `i = i'` `i' \ i''` by simp + ultimately show ?thesis using RecvMarker assms(5) no_snap by auto + qed + moreover have "Msg m # msgs e' i = msgs d' i" + by (metis Recv \i = i'\ assms(6) next_recv) + ultimately show ?thesis using msgs_d + by (metis list.inject) + qed + qed + next + assume "i = i''" + then have "msgs d i = msgs c i" using assms + by (metis Recv \i' \ i''\ next_recv) + moreover have "msgs e i = msgs d' i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d p" + by (metis Recv assms(1) next_recv) + then show ?thesis + by (meson assms(2) assms(5) calculation same_messages_2 same_messages_imply_same_resulting_messages) + qed + moreover have "msgs e' i = msgs d' i" + using assms by (metis Recv \i' \ i''\ `i = i''` next_recv) + ultimately show ?thesis by simp + qed + next + assume asm: "~ (i = i' \ i = i'')" + then have "msgs c i = msgs d i" + by (metis Recv assms(1) assms(3) event.distinct_disc(16,18) event.sel(9) msgs_unchanged_for_other_is nonregular_event) + then have "msgs d' i = msgs e i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + by (meson \msgs c i = msgs d i\ assms(2) assms(5) same_messages_2 same_messages_imply_same_resulting_messages) + qed + then show ?thesis + by (metis Recv asm assms(3) assms(6) event.distinct_disc(16,18) event.sel(9) msgs_unchanged_for_other_is nonregular_event) + qed +qed + +lemma swap_RecvMarker_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecvMarker ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_msgs_Recv_RecvMarker by auto + +lemma swap_msgs_Send_RecvMarker: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isRecvMarker ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_msgs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' p' r u u' m where Send: "ev = Send i' p' r u u' m" + by (metis assms(3) event.collapse(2)) + obtain i'' q' s where RecvMarker: "ev' = RecvMarker i'' q' s" + by (metis assms(4) event.collapse(5)) + have "p' \ q'" using Send RecvMarker assms by simp + show ?thesis + proof (cases "i = i'"; cases "i = i''", goal_cases) + case 1 + then have "msgs e' i = msgs d' i @ [Msg m]" + by (metis Send assms(6) next_send) + moreover have "Marker # msgs d' i = msgs c i" using `i = i''` RecvMarker assms by simp + moreover have "msgs d i = msgs c i @ [Msg m]" + by (metis "1"(1) Send assms(1) next_send) + moreover have "Marker # msgs e i = msgs d i" using `i = i''` RecvMarker assms by simp + ultimately show ?thesis + by (metis append_self_conv2 list.inject list.sel(3) message.distinct(1) tl_append2) + next + case 2 + then have pqpr: "(p, q) = (p', r)" using chan Send can_occur_def assms by simp + then have "msgs d i = msgs c i @ [Msg m]" + by (metis 2(1) Send assms(1) next_send) + moreover have "msgs e' i = msgs d' i @ [Msg m]" + by (metis "2"(1) Send assms(6) next_send) + moreover have "msgs d' i = msgs c i" + proof - + have "\r. channel i = Some (q', r)" using `p' \ q'` chan pqpr by simp + with RecvMarker `i \ i''` `i = i'` assms show ?thesis by (cases "has_snapshotted c q'", auto) + qed + moreover have "msgs e i = msgs d i" + proof - + have "\r. channel i = Some (q', r)" using `p' \ q'` chan pqpr by simp + with RecvMarker `i \ i''` `i = i'` assms show ?thesis by (cases "has_snapshotted d q'", auto) + qed + ultimately show ?thesis by simp + next + assume 3: "i \ i'" "i = i''" + then have mcd: "msgs c i = msgs d i" + by (metis Send assms(1) next_send) + moreover have "msgs e i = msgs d' i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + moreover have "~ regular_event ev'" using assms by auto + ultimately show ?thesis using mcd assms(2,5) by (blast intro: same_messages_2[symmetric]) + qed + moreover have "msgs e' i = msgs d' i" + by (metis "3"(1) Send assms(6) next_send) + ultimately show ?thesis by simp + next + assume 4: "i \ i'" "i \ i''" + have mcd: "msgs c i = msgs d i" + by (metis "4"(1) Send assms(1) assms(3) event.distinct_disc(12,14) event.sel(8) msgs_unchanged_for_other_is nonregular_event) + have "msgs d' i = msgs e i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + moreover have "~ regular_event ev'" using assms by auto + ultimately show ?thesis using mcd assms(2,5) same_messages_2 by blast + qed + moreover have "msgs e' i = msgs d' i" + by (metis "4"(1) Send assms(6) next_send) + ultimately show ?thesis by simp + qed +qed + +lemma swap_RecvMarker_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecvMarker ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "msgs e i = msgs e' i" + using assms swap_msgs_Send_RecvMarker by auto + +lemma swap_cs_Trans_Snapshot: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isTrans ev" and + "isSnapshot ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_cs_change_if_no_channel) +next + case False + then obtain p q where "channel i = Some (p, q)" by auto + have nr: "~ regular_event ev'" + using assms(4) nonregular_event by blast + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain u'' u''' where "ev = Trans ?p u'' u'''" + by (metis assms(3) event.collapse(1)) + have "ev' = Snapshot ?q" + by (metis assms(4) event.collapse(4)) + have "cs d i = cs c i" + by (metis assms(1) assms(3) event.distinct_disc(4) no_cs_change_if_no_event regular_event) + then have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + also have "... = cs e' i" + using assms(3) assms(6) no_cs_change_if_no_event regular_event by blast + finally show ?thesis by simp +qed + +lemma swap_cs_Snapshot_Trans: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSnapshot ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" + using swap_cs_Trans_Snapshot assms by auto + +lemma swap_cs_Send_Snapshot: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isSnapshot ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_cs_change_if_no_channel) +next + case False + then obtain p q where "channel i = Some (p, q)" by auto + have nr: "~ regular_event ev'" + using assms(4) nonregular_event by blast + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Send: "ev = Send i' ?p r u u' m" + by (metis assms(3) event.collapse(2)) + have Snapshot: "ev' = Snapshot ?q" + by (metis assms(4) event.collapse(4)) + have "cs d i = cs c i" + by (metis Send assms(1) next_send) + then have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + also have "... = cs e' i" + using assms(3) assms(6) no_cs_change_if_no_event regular_event by blast + finally show ?thesis by simp +qed + +lemma swap_cs_Snapshot_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSnapshot ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" + using swap_cs_Send_Snapshot assms by auto + +lemma swap_cs_Recv_Snapshot: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isSnapshot ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "cs e i = cs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_cs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + have nr: "~ regular_event ev'" + using assms(4) nonregular_event by blast + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Recv: "ev = Recv i' ?p r u u' m" + by (metis assms(3) event.collapse(3)) + have Snapshot: "ev' = Snapshot ?q" + by (metis assms(4) event.collapse(4)) + show ?thesis + proof (cases "i = i'") + case True + then show ?thesis + proof (cases "snd (cs c i) = Recording") + case True + then have "cs d i = (fst (cs c i) @ [m], Recording)" using Recv assms True `i = i'` chan + by (metis next_recv) + moreover have "cs e i = cs d i" + by (metis Snapshot assms(2) calculation fst_conv next_snapshot) + moreover have "cs c i = cs d' i" + by (metis Snapshot True assms(5) next_snapshot prod.collapse) + moreover have "cs e' i = (fst (cs d' i) @ [m], Recording)" + by (metis (mono_tags, lifting) Recv assms(1) assms(6) calculation(1) calculation(3) next_recv) + ultimately show ?thesis by simp + next + case False + have "cs d i = cs c i" + by (metis False Recv assms(1) next_recv) + have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + moreover have "cs d' i = cs e' i" + proof - + have "cs d' i = cs c i" + by (metis Pair_inject Recv Snapshot True assms(1) assms(5) assms(7) can_occur_Recv distributed_system.happen_implies_can_occur distributed_system.next_snapshot distributed_system_axioms option.inject) + then show ?thesis using chan `i = i'` False Recv assms + by (metis next_recv) + qed + ultimately show ?thesis by simp + qed + next + case False + have "cs d i = cs c i" + by (metis False Recv assms(1) next_recv) + then have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + also have "... = cs e' i" + by (metis False Recv assms(6) next_recv) + finally show ?thesis by simp + qed +qed + +lemma swap_cs_Snapshot_Recv: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSnapshot ev" and + "isRecv ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "cs e i = cs e' i" + using swap_cs_Recv_Snapshot assms by auto + +lemma swap_cs_Trans_RecvMarker: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isTrans ev" and + "isRecvMarker ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_cs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + have nr: "~ regular_event ev'" + using assms(4) nonregular_event by blast + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain u'' u''' where "ev = Trans ?p u'' u'''" + by (metis assms(3) event.collapse(1)) + obtain i' s where "ev' = RecvMarker i' ?q s" + by (metis assms(4) event.collapse(5)) + have "cs d i = cs c i" + by (metis assms(1) assms(3) event.distinct_disc(4) no_cs_change_if_no_event regular_event) + then have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + also have "... = cs e' i" + using assms(3) assms(6) no_cs_change_if_no_event regular_event by blast + finally show ?thesis by simp +qed + +lemma swap_cs_RecvMarker_Trans: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecvMarker ev" and + "isTrans ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" + using swap_cs_Trans_RecvMarker assms by auto + +lemma swap_cs_Send_RecvMarker: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isSend ev" and + "isRecvMarker ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_cs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + have nr: "~ regular_event ev'" + using assms(4) nonregular_event by blast + let ?p = "occurs_on ev" + let ?q = "occurs_on ev'" + obtain i' r u u' m where Send: "ev = Send i' ?p r u u' m" + by (metis assms(3) event.collapse(2)) + obtain i'' s where RecvMarker: "ev' = RecvMarker i'' ?q s" + by (metis assms(4) event.collapse(5)) + have "cs d i = cs c i" + by (metis assms(1) assms(3) event.distinct_disc(10,12,14) no_cs_change_if_no_event nonregular_event) + then have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + also have "... = cs e' i" + using assms(3) assms(6) no_cs_change_if_no_event regular_event by blast + finally show ?thesis by simp +qed + +lemma swap_cs_RecvMarker_Send: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecvMarker ev" and + "isSend ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" + shows + "cs e i = cs e' i" + using swap_cs_Send_RecvMarker assms by auto + +lemma swap_cs_Recv_RecvMarker: + assumes + "c \ ev \ d" and + "d \ ev' \ e" and + "isRecv ev" and + "isRecvMarker ev'" and + "c \ ev' \ d'" and + "d' \ ev \ e'" and + "occurs_on ev \ occurs_on ev'" + shows + "cs e i = cs e' i" +proof (cases "channel i = None") + case True + then show ?thesis + by (metis assms(1) assms(2) assms(5) assms(6) no_cs_change_if_no_channel) +next + case False + then obtain p q where chan: "channel i = Some (p, q)" by auto + have nr: "~ regular_event ev'" + using assms(4) nonregular_event by blast + obtain i' p' r u u' m where Recv: "ev = Recv i' p' r u u' m" + by (metis assms(3) event.collapse(3)) + obtain i'' q' s where RecvMarker: "ev' = RecvMarker i'' q' s" + by (metis assms(4) event.collapse(5)) + have "i' \ i''" + proof (rule ccontr) + assume "~ i' \ i''" + then have "channel i' = channel i''" by simp + then have "(r, p') = (s, q')" using Recv RecvMarker assms can_occur_def by simp + then show False using Recv RecvMarker assms can_occur_def by simp + qed + show ?thesis + proof (cases "i = i'") + case True + then have pqrp: "(p, q) = (r, p')" using Recv assms can_occur_def chan by simp + then show ?thesis + proof (cases "snd (cs c i)") + case NotStarted + then have "cs d i = cs c i" using assms Recv `i = i'` by simp + moreover have "cs d' i = cs e i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + with assms(2,5) calculation show ?thesis by (blast intro: same_cs_2[symmetric]) + qed + thm same_cs_2 + moreover have "cs d' i = cs e' i" + proof - + have "cs d' i = cs c i" + proof - + have "\r. channel i = Some (r, q')" + using Recv RecvMarker assms(7) chan pqrp by auto + with RecvMarker assms chan `i = i'` `i' \ i''` show ?thesis + by (cases "has_snapshotted c q'", auto) + qed + then show ?thesis using assms Recv `i = i'` NotStarted by simp + qed + ultimately show ?thesis by simp + next + case Done + then have "cs d i = cs c i" using assms Recv `i = i'` by simp + moreover have "cs d' i = cs e i" + proof - + have "\p. has_snapshotted c p = has_snapshotted d p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis using assms(2,5) calculation by (blast intro: same_cs_2[symmetric]) + qed + moreover have "cs d' i = cs e' i" + proof - + have "cs d' i = cs c i" + proof - + have "\r. channel i = Some (r, q')" + using Recv RecvMarker assms(7) chan pqrp by auto + with RecvMarker assms chan `i = i'` `i' \ i''` show ?thesis + by (cases "has_snapshotted c q'", auto) + qed + then show ?thesis using assms Recv `i = i'` Done by simp + qed + ultimately show ?thesis by simp + next + case Recording + have "cs d i = (fst (cs c i) @ [m], Recording)" + using Recording Recv True assms(1) by auto + moreover have "cs e i = cs d i" + proof - + have "\r. channel i = Some (r, q')" + using Recv RecvMarker assms(7) chan pqrp by auto + with RecvMarker assms chan `i = i'` `i' \ i''` show ?thesis + by (cases "has_snapshotted d q'", auto) + qed + moreover have "cs c i = cs d' i " + proof - + have "\r. channel i = Some (r, q')" + using Recv RecvMarker assms(7) chan pqrp by auto + with RecvMarker assms chan `i = i'` `i' \ i''` show ?thesis + by (cases "has_snapshotted c q'", auto) + qed + moreover have "cs e' i = (fst (cs d' i) @ [m], Recording)" + using Recording Recv True assms(6) calculation(3) by auto + ultimately show ?thesis by simp + qed + next + case False + have "cs d i = cs c i" + using False Recv assms(1) by auto + then have "cs e i = cs d' i" + proof - + have "\p. has_snapshotted d p = has_snapshotted c p" + using assms(1) assms(3) regular_event_preserves_process_snapshots by auto + then show ?thesis + using \cs d i = cs c i\ assms(2) assms(5) same_cs_2 by blast + qed + also have "... = cs e' i" + using False Recv assms(6) by auto + finally show ?thesis by simp + qed +qed + +end (* context distributed_system *) + +end (* theory Swap *) diff --git a/thys/Chandy_Lamport/Trace.thy b/thys/Chandy_Lamport/Trace.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Trace.thy @@ -0,0 +1,581 @@ +section \Traces\ + +text \Traces extend transitions to finitely many intermediate events.\ + +theory Trace + imports + "HOL-Library.Sublist" + Distributed_System + +begin + +context distributed_system + +begin + +text \We can think of a trace as the transitive closure of the next +relation. A trace consists of initial and final configurations $c$ and +$c'$, with an ordered list of events $t$ occurring sequentially on $c$, +yielding $c'$.\ + +inductive (in distributed_system) trace where + tr_init: "trace c [] c" + | tr_step: "\ c \ ev \ c'; trace c' t c'' \ + \ trace c (ev # t) c''" + +subsection \Properties of traces\ + +lemma trace_trans: + shows + "\ trace c t c'; + trace c' t' c'' + \ \ trace c (t @ t') c''" +proof (induct c t c' rule:trace.induct) + case tr_init + then show ?case by simp +next + case tr_step + then show ?case using trace.tr_step by auto +qed + +lemma trace_decomp_head: + assumes + "trace c (ev # t) c'" + shows + "\c''. c \ ev \ c'' \ trace c'' t c'" + using assms trace.simps by blast + +lemma trace_decomp_tail: + shows + "trace c (t @ [ev]) c' \ \c''. trace c t c'' \ c'' \ ev \ c'" +proof (induct t arbitrary: c) + case Nil + then show ?case + by (metis (mono_tags, lifting) append_Nil distributed_system.trace.simps distributed_system_axioms list.discI list.sel(1) list.sel(3)) +next + case (Cons ev' t) + then obtain d where step: "c \ ev' \ d" and "trace d (t @ [ev]) c'" using trace_decomp_head by force + then obtain d' where tr: "trace d t d'" and "d' \ ev \ c'" using Cons.hyps by blast + moreover have "trace c (ev' # t) d'" using step tr trace.tr_step by simp + ultimately show ?case by auto +qed + +lemma trace_snoc: + assumes + "trace c t c'" and + "c' \ ev \ c''" + shows + "trace c (t @ [ev]) c''" + using assms(1) assms(2) tr_init tr_step trace_trans by auto + +lemma trace_rev_induct [consumes 1, case_names tr_rev_init tr_rev_step]: + "\ trace c t c'; + (\c. P c [] c); + (\c t c' ev c''. trace c t c' \ P c t c' \ c' \ ev \ c'' \ P c (t @ [ev]) c'') + \ \ P c t c'" +proof (induct t arbitrary: c' rule:rev_induct) + case Nil + then show ?case + using distributed_system.trace.cases distributed_system_axioms by blast +next + case (snoc ev t) + then obtain c'' where "trace c t c''" "c'' \ ev \ c'" using trace_decomp_tail by blast + then show ?case using snoc by simp +qed + +lemma trace_and_start_determines_end: + shows + "trace c t c' \ trace c t d' \ c' = d'" +proof (induct c t c' arbitrary: d' rule:trace_rev_induct) + case tr_rev_init + then show ?case using trace.cases by fastforce +next + case (tr_rev_step c t c' ev c'') + then obtain d'' where "trace c t d''" "d'' \ ev \ d'" using trace_decomp_tail by blast + then show ?case using tr_rev_step state_and_event_determine_next by simp +qed + +lemma suffix_split_trace: + shows + "\ trace c t c'; + suffix t' t + \ \ \c''. trace c'' t' c'" +proof (induct t arbitrary: c) + case Nil + then have "t' = []" by simp + then have "trace c' t' c'" using tr_init by simp + then show ?case by blast +next + case (Cons ev t'') + from Cons.prems have q: "suffix t' t'' \ t' = ev # t''" by (meson suffix_Cons) + thus ?case + proof (cases "suffix t' t''") + case True + then show ?thesis using Cons.hyps Cons.prems(1) trace.simps by blast + next + case False + hence "t' = ev # t''" using q by simp + thus ?thesis using Cons.hyps Cons.prems by blast + qed +qed + +lemma prefix_split_trace: + fixes + c :: "('p, 's, 'm) configuration" and + t :: "('p, 's, 'm) trace" + shows + "\ \c'. trace c t c'; + prefix t' t + \ \ \c''. trace c t' c''" +proof (induct t rule:rev_induct) + case Nil + then show ?case by simp +next + case (snoc ev t'') + from snoc.prems have q: "prefix t' t'' \ t' = t'' @ [ev]" by auto + thus ?case + proof (cases "prefix t' t''") + case True + thus ?thesis using trace_decomp_tail using snoc.hyps snoc.prems(1) trace.simps by blast + next + case False + thus ?thesis using q snoc.prems by fast + qed +qed + +lemma split_trace: + shows + "\ trace c t c'; + t = t' @ t'' + \ \ \c''. trace c t' c'' \ trace c'' t'' c'" +proof (induct t'' arbitrary: t') + case Nil + then show ?case using tr_init by auto +next + case (Cons ev t'') + obtain c'' where p: "trace c (t' @ [ev]) c''" + using Cons.prems prefix_split_trace rotate1.simps(2) by force + then have "trace c'' t'' c'" + using Cons.hyps Cons.prems trace_and_start_determines_end by force + then show ?case + by (meson distributed_system.tr_step distributed_system.trace_decomp_tail distributed_system_axioms p) +qed + +subsection \Describing intermediate configurations\ + +definition construct_fun_from_rel :: "('a * 'b) set \ 'a \ 'b" where + "construct_fun_from_rel R x = (THE y. (x,y) \ R)" + +definition trace_rel where + "trace_rel \ {((x, t'), y). trace x t' y}" + +lemma fun_must_admit_trace: + shows + "single_valued R \ x \ Domain R + \ (x, construct_fun_from_rel R x) \ R" + unfolding construct_fun_from_rel_def + by (rule theI') (auto simp add: single_valued_def) + +lemma single_valued_trace_rel: + shows + "single_valued trace_rel" +proof (rule single_valuedI) + fix x y y' + assume asm: "(x, y) \ trace_rel" "(x, y') \ trace_rel" + then obtain x' t where "x = (x', t)" + by (meson surj_pair) + then have "trace x' t y" "trace x' t y'" + using asm trace_rel_def by auto + then show "y = y'" + using trace_and_start_determines_end by blast +qed + +definition run_trace where + "run_trace \ construct_fun_from_rel trace_rel" + +text \In order to describe intermediate configurations +of a trace we introduce the $s$ function definition, which, +given an initial configuration $c$, a trace $t$ and an index $i \in \mathbb{N}$, +determines the unique state after the first $i$ events of $t$.\ + +definition s where + "s c t i = (THE c'. trace c (take i t) c')" + +lemma s_is_partial_execution: + shows + "s c t i = run_trace (c, take i t)" + unfolding s_def run_trace_def + construct_fun_from_rel_def trace_rel_def + by auto + +lemma exists_trace_for_any_i: + assumes + "\c'. trace c t c'" + shows + "trace c (take i t) (s c t i)" +proof - + have "prefix (take i t) t" using take_is_prefix by auto + then obtain c'' where tr: "trace c (take i t) c''" using assms prefix_split_trace by blast + then show ?thesis + proof - + have "((c, take i t), s c t i) \ trace_rel" + unfolding s_def trace_rel_def construct_fun_from_rel_def + by (metis case_prod_conv distributed_system.trace_and_start_determines_end distributed_system_axioms mem_Collect_eq the_equality tr) + then show ?thesis by (simp add: trace_rel_def) + qed +qed + +lemma exists_trace_for_any_i_j: + assumes + "\c'. trace c t c'" and + "i \ j" + shows + "trace (s c t i) (take (j - i) (drop i t)) (s c t j)" +proof - + have "trace c (take j t) (s c t j)" using exists_trace_for_any_i assms by simp + from `j \ i` have "take j t = take i t @ (take (j - i) (drop i t))" + by (metis le_add_diff_inverse take_add) + then have "trace c (take i t) (s c t i) \ trace (s c t i) (take (j - i) (drop i t)) (s c t j)" + by (metis (no_types, lifting) assms(1) exists_trace_for_any_i split_trace trace_and_start_determines_end) + then show ?thesis by simp +qed + +lemma step_Suc: + assumes + "i < length t" and + valid: "trace c t c'" + shows "(s c t i) \ (t ! i) \ (s c t (Suc i))" +proof - + have ex_trace: "trace (s c t i) (take (Suc i - i) (drop i t)) (s c t (Suc i))" + using exists_trace_for_any_i_j le_less valid by blast + moreover have "Suc i - i = 1" by auto + moreover have "take 1 (drop i t) = [t ! i]" + by (metis \Suc i - i = 1\ assms(1) hd_drop_conv_nth le_add_diff_inverse lessI nat_less_le same_append_eq take_add take_hd_drop) + ultimately show ?thesis + by (metis list.discI trace.simps trace_decomp_head) +qed + +subsection \Trace-related lemmas\ + +lemma snapshot_state_unchanged_trace: + assumes + "trace c t c'" and + "ps c p = Some u" + shows + "ps c' p = Some u" + using assms snapshot_state_unchanged by (induct c t c', auto) + +lemma no_state_change_if_only_nonregular_events: + shows + "\ trace c t c'; + \ev. ev \ set t \ regular_event ev \ occurs_on ev = p; + states c p = st + \ \ states c' p = st" +proof (induct c t c' rule:trace_rev_induct) + case (tr_rev_init c) + then show ?case by simp +next + case (tr_rev_step c t c' ev c'') + then have "states c' p = st" + proof - + have "\ev. ev : set t \ regular_event ev \ occurs_on ev = p" + using tr_rev_step by auto + then show ?thesis using tr_rev_step by blast + qed + then show ?case + using tr_rev_step no_state_change_if_no_event no_state_change_if_nonregular_event + by auto +qed + +lemma message_must_be_delivered_2_trace: + assumes + "trace c t c'" and + "m : set (msgs c i)" and + "m \ set (msgs c' i)" and + "channel i = Some (q, p)" + shows + "\ev \ set t. (\p q. ev = RecvMarker i p q \ m = Marker) \ (\p q s s' m'. ev = Recv i q p s s' m' \ m = Msg m')" +proof (rule ccontr) + assume "~ (\ev \ set t. (\p q. ev = RecvMarker i p q \ m = Marker) \ (\p q s s' m'. ev = Recv i q p s s' m' \ m = Msg m'))" (is ?P) + have "\ trace c t c'; m : set (msgs c i); ?P \ \ m : set (msgs c' i)" + proof (induct c t c' rule:trace_rev_induct) + case (tr_rev_init c) + then show ?case by simp + next + case (tr_rev_step c t d ev c') + then have m_in_set: "m : set (msgs d i)" + using tr_rev_step by auto + then show ?case + proof (cases ev) + case (Snapshot r) + then show ?thesis + using distributed_system.message_must_be_delivered_2 distributed_system_axioms m_in_set tr_rev_step.hyps(3) by blast + next + case (RecvMarker i' r s) + then show ?thesis + proof (cases "m = Marker") + case True + then have "i' \ i" using tr_rev_step RecvMarker by simp + then show ?thesis + using RecvMarker m_in_set message_must_be_delivered_2 tr_rev_step.hyps(3) by blast + next + case False + then show ?thesis + using RecvMarker tr_rev_step.hyps(3) m_in_set message_must_be_delivered_2 by blast + qed + next + case (Trans r u u') + then show ?thesis + using tr_rev_step.hyps(3) m_in_set by auto + next + case (Send i' r s u u' m') + then show ?thesis + using distributed_system.message_must_be_delivered_2 distributed_system_axioms m_in_set tr_rev_step.hyps(3) by blast + next + case (Recv i' r s u u' m') + then show ?thesis + proof (cases "Msg m' = m") + case True + then have "i' \ i" using Recv tr_rev_step by auto + then show ?thesis + using Recv m_in_set tr_rev_step(3) by auto + next + case False + then show ?thesis + by (metis Recv event.distinct(17) event.inject(3) m_in_set message_must_be_delivered_2 tr_rev_step.hyps(3)) + qed + qed + qed + then have "m : set (msgs c' i)" using assms `?P` by auto + then show False using assms by simp +qed + +lemma marker_must_be_delivered_2_trace: + assumes + "trace c t c'" and + "Marker : set (msgs c i)" and + "Marker \ set (msgs c' i)" and + "channel i = Some (p, q)" + shows + "\ev \ set t. (\p q. ev = RecvMarker i p q)" +proof - + show "\ev \ set t. (\p q. ev = RecvMarker i p q)" + using assms message_must_be_delivered_2_trace by fast +qed + +lemma snapshot_stable: + shows + "\ trace c t c'; + has_snapshotted c p + \ \ has_snapshotted c' p" +proof (induct c t c' rule:trace_rev_induct) + case (tr_rev_init c) + then show ?case by blast +next + case (tr_rev_step c t c' ev c'') + then show ?case + proof (cases ev) + case (Snapshot q) + then have "p \ q" using tr_rev_step next_snapshot can_occur_def by auto + then show ?thesis using Snapshot tr_rev_step by auto + next + case (RecvMarker i q r) + with tr_rev_step show ?thesis + by (cases "p = q"; auto) + qed simp_all +qed + +lemma snapshot_stable_2: + shows + "trace c t c' \ ~ has_snapshotted c' p \ ~ has_snapshotted c p" + using snapshot_stable by blast + +lemma no_markers_if_all_snapshotted: + shows + "\ trace c t c'; + \p. has_snapshotted c p; + Marker \ set (msgs c i) + \ \ Marker \ set (msgs c' i)" +proof (induct c t c' rule:trace_rev_induct) + case (tr_rev_init c) + then show ?case by simp +next + case (tr_rev_step c t c' ev c'') + have all_snapshotted: "\p. has_snapshotted c' p" using snapshot_stable tr_rev_step by auto + have no_marker: "Marker \ set (msgs c' i)" using tr_rev_step by blast + then show ?case + proof (cases ev) + case (Snapshot r) + then show ?thesis using can_occur_def tr_rev_step all_snapshotted by auto + next + case (RecvMarker i' r s) + have "i' \ i" + proof (rule ccontr) + assume "~ i' \ i" + then have "Marker : set (msgs c i)" + using can_occur_def RecvMarker tr_rev_step RecvMarker_implies_Marker_in_set by blast + then show False using tr_rev_step by simp + qed + then show ?thesis using tr_rev_step all_snapshotted no_marker RecvMarker by auto + next + case (Trans p s s') + then show ?thesis using tr_rev_step no_marker by auto + next + case (Send i' r s u u' m) + then show ?thesis + proof (cases "i' = i") + case True + then have "msgs c'' i = msgs c' i @ [Msg m]" using tr_rev_step Send by auto + then show ?thesis using no_marker by auto + next + case False + then show ?thesis using Send tr_rev_step no_marker by auto + qed + next + case (Recv i' r s u u' m) + then show ?thesis + proof (cases "i = i'") + case True + then have "msgs c'' i = tl (msgs c' i)" using tr_rev_step Recv by auto + then show ?thesis using no_marker by (metis list.sel(2) list.set_sel(2)) + next + case False + then show ?thesis using Recv tr_rev_step no_marker by auto + qed + qed +qed + +lemma event_stays_valid_if_no_occurrence_trace: + shows + "\ trace c t c'; + list_all (\ev. occurs_on ev \ occurs_on ev') t; + can_occur ev' c + \ \ can_occur ev' c'" +proof (induct c t c' rule:trace_rev_induct) + case tr_rev_init + then show ?case by blast +next + case tr_rev_step + then show ?case using event_stays_valid_if_no_occurrence by auto +qed + +lemma event_can_go_back_if_no_sender_trace: + shows + "\ trace c t c'; + list_all (\ev. occurs_on ev \ occurs_on ev') t; + can_occur ev' c'; + ~ isRecvMarker ev'; + list_all (\ev. ~ isSend ev) t + \ \ can_occur ev' c" +proof (induct c t c' rule:trace_rev_induct) + case tr_rev_init + then show ?case by blast +next + case tr_rev_step + then show ?case using event_can_go_back_if_no_sender by auto +qed + +lemma done_only_from_recv_marker_trace: + assumes + "trace c t c'" and + "t \ []" and + "snd (cs c cid) \ Done" and + "snd (cs c' cid) = Done" and + "channel cid = Some (p, q)" + shows + "RecvMarker cid q p \ set t" +proof (rule ccontr) + assume "~ RecvMarker cid q p \ set t" + moreover have "\ trace c t c'; ~ RecvMarker cid q p \ set t; snd (cs c cid) \ Done; channel cid = Some (p, q) \ + \ snd (cs c' cid) \ Done" + proof (induct t arbitrary: c' rule:rev_induct) + case Nil + then show ?case + by (metis list.discI trace.simps) + next + case (snoc ev t) + then obtain d where ind: "trace c t d" and step: "d \ ev \ c'" + using trace_decomp_tail by blast + then have "snd (cs d cid) \ Done" + proof - + have "~ RecvMarker cid q p \ set t" + using snoc.prems(2) by auto + then show ?thesis using snoc ind by blast + qed + then show ?case + using done_only_from_recv_marker local.step snoc.prems(2) snoc.prems(4) by auto + qed + ultimately have "snd (cs c' cid) \ Done" using assms by blast + then show False using assms by simp +qed + +lemma cs_not_not_started_stable_trace: + shows + "\ trace c t c'; snd (cs c cid) \ NotStarted; channel cid = Some (p, q) \ \ snd (cs c' cid) \ NotStarted" +proof (induct t arbitrary:c' rule:rev_induct) + case Nil + then show ?case + by (metis list.discI trace.simps) +next + case (snoc ev t) + then obtain d where tr: "trace c t d" and step: "d \ ev \ c'" + using trace_decomp_tail by blast + then have "snd (cs d cid) \ NotStarted" using snoc by blast + then show ?case using cs_not_not_started_stable snoc step by blast +qed + +lemma no_messages_introduced_if_no_channel: + assumes + trace: "trace init t final" and + no_msgs_if_no_channel: "\i. channel i = None \ msgs init i = []" + shows + "channel cid = None \ msgs (s init t i) cid = []" +proof (induct i) + case 0 + then show ?case + by (metis assms exists_trace_for_any_i no_msgs_if_no_channel take0 tr_init trace_and_start_determines_end) +next + case (Suc n) + have f: "trace (s init t n) (take ((Suc n) - n) (drop n t)) (s init t (Suc n))" + using exists_trace_for_any_i_j order_le_less trace assms by blast + then show ?case + proof (cases "drop n t = Nil") + case True + then show ?thesis using Suc.hyps Suc.prems + by (metis f tr_init trace_and_start_determines_end take_Nil) + next + case False + have suc_n_minus_n: "Suc n - n = 1" by auto + then have "length (take ((Suc n) - n) (drop n t)) = 1" using False by auto + then obtain ev where "ev # Nil = take ((Suc n) - n) (drop n t)" + by (metis False One_nat_def suc_n_minus_n length_greater_0_conv self_append_conv2 take_eq_Nil take_hd_drop) + then have g: "(s init t n) \ ev \ (s init t (Suc n))" + by (metis f tr_init trace_and_start_determines_end trace_decomp_head) + then show ?thesis + proof (cases ev) + case (Snapshot r) + then show ?thesis + using Suc.hyps Suc.prems g by auto + next + case (RecvMarker cid' sr r) + have "cid' \ cid" using RecvMarker can_occur_def g Suc by auto + with RecvMarker Suc g show ?thesis by (cases "has_snapshotted (s init t n) sr", auto) + next + case (Trans r u u') + then show ?thesis + by (metis Suc.hyps Suc.prems g next_trans) + next + case (Send cid' r s u u' m) + have "cid' \ cid" using Send can_occur_def g Suc by auto + then show ?thesis using Suc g Send by simp + next + case (Recv cid' s r u u' m) + have "cid' \ cid" using Recv can_occur_def g Suc by auto + then show ?thesis using Suc g Recv by simp + qed + qed +qed + +end (* context distributed_system *) + +end (* theory Trace *) diff --git a/thys/Chandy_Lamport/Util.thy b/thys/Chandy_Lamport/Util.thy new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/Util.thy @@ -0,0 +1,363 @@ +section \Utilties\ + +theory Util + imports + Main + "HOL-Library.Sublist" + "HOL-Library.Permutation" + +begin + +abbreviation swap_events where + "swap_events i j t \ take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t) @ drop (j+1) t" + +lemma swap_neighbors_2: + shows + "i+1 < length t \ swap_events i (i+1) t = (t[i := t ! (i+1)])[i+1 := t ! i]" +proof (induct i arbitrary: t) + case 0 + then show ?case + by (metis One_nat_def Suc_eq_plus1 add_lessD1 append.left_neutral append_Cons cancel_comm_monoid_add_class.diff_cancel drop_update_cancel length_list_update numeral_One take_0 take_Cons_numeral upd_conv_take_nth_drop zero_less_Suc) +next + case (Suc n) + let ?t = "tl t" + have "t = hd t # ?t" + by (metis Suc.prems hd_Cons_tl list.size(3) not_less_zero) + moreover have "swap_events n (n+1) ?t = (?t[n := ?t ! (n+1)])[n+1 := ?t ! n]" + by (metis Suc.hyps Suc.prems Suc_eq_plus1 length_tl less_diff_conv) + ultimately show ?case + by (metis Suc_eq_plus1 append_Cons diff_self_eq_0 drop_Suc_Cons list_update_code(3) nth_Cons_Suc take_Suc_Cons) +qed + +lemma swap_identical_length: + assumes + "i < j" and + "j < length t" + shows + "length t = length (swap_events i j t)" +proof - + have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t)) + = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))" + by simp + then have "... = j+1" + using assms(1) assms(2) by auto + then show ?thesis using assms(2) by auto +qed + +lemma swap_identical_heads: + assumes + "i < j" and + "j < length t" + shows + "take i t = take i (swap_events i j t)" + using assms by auto + +lemma swap_identical_tails: + assumes + "i < j" and + "j < length t" + shows + "drop (j+1) t = drop (j+1) (swap_events i j t)" +proof - + have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t)) + = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))" + by simp + then have "... = j+1" + using assms(1) assms(2) by auto + then show ?thesis + by (metis \length (take i t @ [t ! j, t ! i] @ take (j - (i + 1)) (drop (i + 1) t)) = length (take i t) + length [t ! j, t ! i] + length (take (j - (i + 1)) (drop (i + 1) t))\ append.assoc append_eq_conv_conj) +qed + +lemma swap_neighbors: + shows + "i+1 < length l \ (l[i := l ! (i+1)])[i+1 := l ! i] = take i l @ [l ! (i+1), l ! i] @ drop (i+2) l" +proof (induct i arbitrary: l) + case 0 + then show ?case + by (metis One_nat_def add.left_neutral add_lessD1 append_Cons append_Nil drop_update_cancel length_list_update one_add_one plus_1_eq_Suc take0 take_Suc_Cons upd_conv_take_nth_drop zero_less_two) +next + case (Suc n) + let ?l = "tl l" + have "(l[Suc n := l ! (Suc n + 1)])[Suc n + 1 := l ! Suc n] = hd l # (?l[n := ?l ! (n+1)])[n+1 := ?l ! n]" + by (metis Suc.prems add.commute add_less_same_cancel2 list.collapse list.size(3) list_update_code(3) not_add_less2 nth_Cons_Suc plus_1_eq_Suc) + have "n + 1 < length ?l" using Suc.prems by auto + then have "(?l[n := ?l ! (n+1)])[n+1 := ?l ! n] = take n ?l @ [?l ! (n+1), ?l ! n] @ drop (n+2) ?l" + using Suc.hyps by simp + then show ?case + by (cases l) auto +qed + +lemma swap_events_perm: + assumes + "i < j" and + "j < length t" + shows + "perm (swap_events i j t) t" +proof - + have swap: "swap_events i j t + = take i t @ [t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t)) @ (drop (j+1) t)" + by auto + have reg: "t = take i t @ (take ((j+1) - i) (drop i t)) @ drop (j+1) t" + by (metis add_diff_inverse_nat add_lessD1 append.assoc append_take_drop_id assms(1) less_imp_add_positive less_not_refl take_add) + have "perm (take i t) (take i t)" by simp + moreover have "perm (drop (j+1) t) (drop (j+1) t)" by simp + moreover have "perm ([t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t))) (take ((j+1) - i) (drop i t))" + proof - + let ?l = "take (j - (i+1)) (drop (i+1) t)" + have "take ((j+1) - i) (drop i t) = t ! i # ?l @ [t ! j]" + proof - + have f1: "Suc (j - Suc i) = j - i" + by (meson Suc_diff_Suc assms(1)) + have f2: "i < length t" + using assms(1) assms(2) by linarith + have f3: "j - (i + 1) + (i + 1) = j" + by (meson assms(1) discrete le_add_diff_inverse2) + then have "drop (j - (i + 1)) (drop (i + 1) t) = drop j t" + by (metis drop_drop) + then show ?thesis + using f3 f2 f1 by (metis (no_types) Cons_nth_drop_Suc Suc_diff_le Suc_eq_plus1 assms(1) assms(2) hd_drop_conv_nth length_drop less_diff_conv nat_less_le take_Suc_Cons take_hd_drop) + qed + then show ?thesis using mset_eq_perm by fastforce + qed + ultimately show ?thesis using swap reg + by (metis append.assoc perm_append1 perm_append2) +qed + +lemma sum_eq_if_same_subterms: + fixes + i :: nat + shows + "\k. i \ k \ k < j \ f k = f' k \ sum f {i..) a) l \ takeWhile ((\) a) l" + shows + "\i j. i < j \ j < length l \ l ! i = a \ l ! j \ a" (is ?P) +proof (rule ccontr) + assume "~ ?P" + then have asm: "\i j. i < j \ j < length l \ l ! i \ a \ l ! j = a" (is ?Q) by simp + then have "filter ((\) a) l = takeWhile ((\) a) l" + proof (cases "a : set l") + case False + then have "\i. i < length l \ l ! i \ a" by auto + then show ?thesis + by (metis (mono_tags, lifting) False filter_True takeWhile_eq_all_conv) + next + case True + then have ex_j: "\j. j < length l \ l ! j = a" + by (simp add: in_set_conv_nth) + let ?j = "Min {j. j < length l \ l ! j = a}" + have fin_j: "finite {j. j < length l \ l ! j = a}" + using finite_nat_set_iff_bounded by blast + moreover have "{j. j < length l \ l ! j = a} \ empty" using ex_j by blast + ultimately have "?j < length l" + using Min_less_iff by blast + have tail_all_a: "\j. j < length l \ j \ ?j \ l ! j = a" + proof (rule allI, rule impI) + fix j + assume "j < length l \ j \ ?j" + moreover have "\ ?Q; j < length l \ j \ ?j \ \ \k. k \ ?j \ k \ j \ l ! j = a" + proof (induct "j - ?j") + case 0 + then have "j = ?j" using 0 by simp + then show ?case + using Min_in \{j. j < length l \ l ! j = a} \ {}\ fin_j by blast + next + case (Suc n) + then have "\k. k \ ?j \ k < j \ l ! j = a" + by (metis (mono_tags, lifting) Min_in \{j. j < length l \ l ! j = a} \ {}\ fin_j le_eq_less_or_eq mem_Collect_eq) + then show ?case + using Suc.hyps(2) by auto + qed + ultimately show "l ! j = a" using asm by blast + qed + moreover have head_all_not_a: "\i. i < ?j \ l ! i \ a" using asm calculation + by (metis (mono_tags, lifting) Min_le \Min {j. j < length l \ l ! j = a} < length l\ fin_j leD less_trans mem_Collect_eq) + ultimately have "takeWhile ((\) a) l = take ?j l" + proof - + have "length (takeWhile ((\) a) l) = ?j" + proof - + have "length (takeWhile ((\) a) l) \ ?j" (is ?S) + proof (rule ccontr) + assume "\ ?S" + then have "l ! ?j \ a" + by (metis (mono_tags, lifting) not_le_imp_less nth_mem set_takeWhileD takeWhile_nth) + then show False + using \Min {j. j < length l \ l ! j = a} < length l\ tail_all_a by blast + qed + moreover have "length (takeWhile ((\) a) l) \ ?j" (is ?T) + proof (rule ccontr) + assume "\ ?T" + then have "\j. j < ?j \ l ! j = a" + by (metis (mono_tags, lifting) \Min {j. j < length l \ l ! j = a} < length l\ calculation le_less_trans not_le_imp_less nth_length_takeWhile) + then show False + using head_all_not_a by blast + qed + ultimately show ?thesis by simp + qed + moreover have "length (take ?j l) = ?j" + by (metis calculation takeWhile_eq_take) + ultimately show ?thesis + by (metis takeWhile_eq_take) + + qed + moreover have "filter ((\) a) l = take ?j l" + proof - + have "filter ((\) a) l = filter ((\) a) (take ?j l) @ filter ((\) a) (drop ?j l)" + by (metis append_take_drop_id filter_append) + moreover have "filter ((\) a) (take ?j l) = take ?j l" using head_all_not_a + by (metis \takeWhile ((\) a) l = take (Min {j. j < length l \ l ! j = a}) l\ filter_id_conv set_takeWhileD) + moreover have "filter ((\) a) (drop ?j l) = []" + proof - + have "\j. j \ ?j \ j < length l \ l ! j = drop ?j l ! (j - ?j)" + by simp + then have "\j. j < length l - ?j \ drop ?j l ! j = a" using tail_all_a + by (metis (no_types, lifting) Groups.add_ac(2) \Min {j. j < length l \ l ! j = a} < length l\ less_diff_conv less_imp_le_nat not_add_less2 not_le nth_drop) + then show ?thesis + proof - + obtain aa :: "('a \ bool) \ 'a list \ 'a" where + "\x0 x1. (\v2. v2 \ set x1 \ x0 v2) = (aa x0 x1 \ set x1 \ x0 (aa x0 x1))" + by moura + then have f1: "\as p. aa p as \ set as \ p (aa p as) \ filter p as = []" + by (metis (full_types) filter_False) + obtain nn :: "'a list \ 'a \ nat" where + f2: "\x0 x1. (\v2 x0 ! nn x0 x1 = x1)" + by moura + { assume "drop (Min {n. n < length l \ l ! n = a}) l ! nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) = a" + then have "filter ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l) = [] \ \ nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) < length (drop (Min {n. n < length l \ l ! n = a}) l) \ drop (Min {n. n < length l \ l ! n = a}) l ! nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) \ aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)" + using f1 by (metis (full_types)) } + moreover + { assume "\ nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) < length l - Min {n. n < length l \ l ! n = a}" + then have "\ nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) < length (drop (Min {n. n < length l \ l ! n = a}) l) \ drop (Min {n. n < length l \ l ! n = a}) l ! nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) \ aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)" + by simp } + ultimately have "filter ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l) = [] \ \ nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) < length (drop (Min {n. n < length l \ l ! n = a}) l) \ drop (Min {n. n < length l \ l ! n = a}) l ! nn (drop (Min {n. n < length l \ l ! n = a}) l) (aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)) \ aa ((\) a) (drop (Min {n. n < length l \ l ! n = a}) l)" + using \\j l ! j = a}. drop (Min {j. j < length l \ l ! j = a}) l ! j = a\ by blast + then show ?thesis + using f2 f1 by (meson in_set_conv_nth) + qed + qed + ultimately show ?thesis by simp + qed + ultimately show ?thesis by simp + qed + then show False using assms by simp +qed + +lemma util_exactly_one_element: + assumes + "m \ set l" and + "l' = l @ [m]" + shows + "\!j. j < length l' \ l' ! j = m" (is ?P) +proof - + have "\j. j < length l' - 1 \ l' ! j \ m" + by (metis assms(1) assms(2) butlast_snoc length_butlast nth_append nth_mem) + then have one_j: "\j. j < length l' \ l' ! j = m \ j = (length l' - 1)" + by (metis (no_types, hide_lams) diff_Suc_1 lessE) + show ?thesis + proof (rule ccontr) + assume "~ ?P" + then obtain i j where "i \ j" "i < length l'" "j < length l'" + "l' ! i = m" "l' ! j = m" + using assms by auto + then show False using one_j by blast + qed +qed + +lemma exists_one_iff_filter_one: + shows + "(\!j. j < length l \ l ! j = a) \ length (filter ((=) a) l) = 1" +proof (rule iffI) + assume "\!j. j < length l \ l ! j = a" + then obtain j where "j < length l" "l ! j = a" + by blast + moreover have "\k. k \ j \ k < length l \ l ! k \ a" + using \\!j. j < length l \ l ! j = a\ \j < length l\ \l ! j = a\ by blast + moreover have "l = take j l @ [l ! j] @ drop (j+1) l" + by (metis Cons_eq_appendI Cons_nth_drop_Suc Suc_eq_plus1 append_self_conv2 append_take_drop_id calculation(1) calculation(2)) + moreover have "filter ((=) a) (take j l) = []" + proof - + have "\k. k < length (take j l) \ (take j l) ! k \ a" + using calculation(3) by auto + then show ?thesis + by (metis (full_types) filter_False in_set_conv_nth) + qed + moreover have "filter ((=) a) (drop (j+1) l) = []" + proof - + have "\k. k < length (drop (j+1) l) \ (drop (j+1) l) ! k \ a" + using calculation(3) by auto + then show ?thesis + by (metis (full_types) filter_False in_set_conv_nth) + qed + ultimately show "length (filter ((=) a) l) = 1" + by (metis (mono_tags, lifting) One_nat_def Suc_eq_plus1 append_Cons append_self_conv2 filter.simps(2) filter_append list.size(3) list.size(4)) +next + assume asm: "length (filter ((=) a) l) = 1" + then have "filter ((=) a) l = [a]" + proof - + let ?xs = "filter ((=) a) l" + have "length ?xs = 1" + using asm by blast + then show ?thesis + by (metis (full_types) Cons_eq_filterD One_nat_def length_0_conv length_Suc_conv) + qed + then have "\j. j < length l \ l ! j = a" + by (metis (full_types) filter_False in_set_conv_nth list.discI) + then obtain j where j: "j < length l" "l ! j = a" by blast + moreover have "\k. k < length l \ k \ j \ l ! k \ a" + proof (rule allI, rule impI) + fix k + assume assm: "k < length l \ k \ j" + show "l ! k \ a" + proof (rule ccontr) + assume lka: "\ l ! k \ a" + show False + proof (cases "k < j") + let ?xs = "take (k+1) l" + let ?ys = "drop (k+1) l" + case True + then have "length (filter ((=) a) ?xs) > 0" + by (metis (full_types, hide_lams) add.commute assm discrete filter_empty_conv length_greater_0_conv length_take less_add_one lka min.absorb2 nth_mem nth_take) + moreover have "length (filter ((=) a) ?ys) > 0" + proof - + have "?ys ! (j - (k+1)) = l ! j" + using True assm by auto + moreover have "j - (k+1) < length ?ys" + using True \j < length l\ by auto + ultimately show ?thesis + by (metis (full_types) \l ! j = a\ filter_empty_conv length_greater_0_conv nth_mem) + qed + moreover have "?xs @ ?ys = l" + using append_take_drop_id by blast + ultimately have "length (filter ((=) a) l) > 1" + by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 asm filter_append length_append less_add_eq_less less_one nat_neq_iff) + then show False using asm by simp + next + let ?xs = "take (j+1) l" + let ?ys = "drop (j+1) l" + case False + then have "length (filter ((=) a) ?xs) > 0" + by (metis (full_types, hide_lams) add.commute j discrete filter_empty_conv length_greater_0_conv length_take less_add_one min.absorb2 nth_mem nth_take) + moreover have "length (filter ((=) a) ?ys) > 0" + proof - + have "?ys ! (k - (j+1)) = l ! k" + using False assm by auto + moreover have "k - (j+1) < length ?ys" + using False assm by auto + ultimately show ?thesis + by (metis (full_types) filter_empty_conv length_greater_0_conv lka nth_mem) + qed + moreover have "?xs @ ?ys = l" + using append_take_drop_id by blast + ultimately have "length (filter ((=) a) l) > 1" + by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 asm filter_append length_append less_add_eq_less less_one nat_neq_iff) + then show False using asm by simp + qed + qed + qed + ultimately show "\!j. j < length l \ l ! j = a" by blast +qed + +end diff --git a/thys/Chandy_Lamport/document/root.bib b/thys/Chandy_Lamport/document/root.bib new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/document/root.bib @@ -0,0 +1,22 @@ +@article{chandy, + author = {K. Mani Chandy and + Leslie Lamport}, + title = {Distributed Snapshots: Determining Global States of Distributed Systems}, + journal = {{ACM} Trans. Comput. Syst.}, + volume = {3}, + number = {1}, + pages = {63--75}, + year = {1985}, + url = {https://doi.org/10.1145/214451.214456}, +} + +@article{Ordered_Resolution_Prover-AFP, + author = {Anders Schlichtkrull and Jasmin Christian Blanchette and Dmitriy Traytel and Uwe Waldmann}, + title = {Formalization of Bachmair and Ganzinger's Ordered Resolution Prover}, + journal = {Archive of Formal Proofs}, + month = jan, + year = 2018, + note = {\url{http://isa-afp.org/entries/Ordered_Resolution_Prover.html}, + Formal proof development}, + ISSN = {2150-914x}, +} diff --git a/thys/Chandy_Lamport/document/root.tex b/thys/Chandy_Lamport/document/root.tex new file mode 100644 --- /dev/null +++ b/thys/Chandy_Lamport/document/root.tex @@ -0,0 +1,70 @@ +\documentclass[11pt,a4paper]{article} +\usepackage{isabelle,isabellesym} + +% further packages required for unusual symbols (see also +% isabellesym.sty), use only when needed + +\usepackage{amssymb} + %for \, \, \, \, \, \, + %\, \, \, \, \, + %\, \, \ + +%\usepackage{eurosym} + %for \ + +%\usepackage[only,bigsqcap]{stmaryrd} + %for \ + +%\usepackage{eufrak} + %for \ ... \, \ ... \ (also included in amssymb) + +%\usepackage{textcomp} + %for \, \, \, \, \, + %\ + +\usepackage{authblk} + +% this should be the last package used +\usepackage{pdfsetup} + +% urls in roman style, theory text in math-similar italics +\urlstyle{rm} +\isabellestyle{it} + +% for uniform font size +%\renewcommand{\isastyle}{\isastyleminor} + +\title{A formal proof of the Chandy--Lamport distributed snapshot algorithm} +\author[1]{Ben Fiedler} +\author[1]{Dmitriy Traytel} +\affil[1]{ETH Z\"urich} + +\begin{document} + +\maketitle + +\begin{abstract} + We provide a suitable distributed system model and implementation the + Chandy--Lamport distributed snapshot algorithm~\cite{chandy}. Our main + result is a formal termination and correctness proof of the Chandy--Lamport + algorithm and its use in stable property detection. +\end{abstract} + +\tableofcontents + +% sane default for proof documents +\parindent 0pt\parskip 0.5ex + +% generated text of all theories +\input{session} + +% optional bibliography +\bibliographystyle{abbrv} +\bibliography{root} + +\end{document} + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: t +%%% End: diff --git a/thys/LLL_Basis_Reduction/LLL.thy b/thys/LLL_Basis_Reduction/LLL.thy --- a/thys/LLL_Basis_Reduction/LLL.thy +++ b/thys/LLL_Basis_Reduction/LLL.thy @@ -1,1690 +1,1745 @@ (* Authors: Jose Divasón Maximilian Haslbeck Sebastiaan Joosten René Thiemann Akihisa Yamada License: BSD *) section \The LLL Algorithm\ text \Soundness of the LLL algorithm is proven in four steps. In the basic version, we do recompute the Gram-Schmidt ortogonal (GSO) basis in every step. This basic version will have a full functional soundness proof, i.e., termination and the property that the returned basis is reduced. Then in LLL-Number-Bounds we will strengthen the invariant and prove that all intermediate numbers stay polynomial in size. Moreover, in LLL-Impl we will refine the basic version, so that the GSO does not need to be recomputed in every step. Finally, in LLL-Complexity, we develop an cost-annotated version of the refined algorithm and prove a polynomial upper bound on the number of arithmetic operations.\ text \This theory provides a basic implementation and a soundness proof of the LLL algorithm to compute a "short" vector in a lattice.\ theory LLL imports Gram_Schmidt_2 Missing_Lemmas Jordan_Normal_Form.Determinant "Abstract-Rewriting.SN_Order_Carrier" begin subsection \Core Definitions, Invariants, and Theorems for Basic Version\ (* Note/TODO by Max Haslbeck: Up to here I refactored the code in Gram_Schmidt_2 and Gram_Schmidt_Int which now makes heavy use of locales. In the future I would also like to do this here (instead of using LLL_invariant everywhere). *) locale LLL = fixes n :: nat (* n-dimensional vectors, *) and m :: nat (* number of vectors *) and fs_init :: "int vec list" (* initial basis *) and \ :: rat (* approximation factor *) begin sublocale vec_module "TYPE(int)" n. abbreviation RAT where "RAT \ map (map_vec rat_of_int)" abbreviation SRAT where "SRAT xs \ set (RAT xs)" abbreviation Rn where "Rn \ carrier_vec n :: rat vec set" sublocale gs: gram_schmidt_fs n "RAT fs_init" . abbreviation lin_indep where "lin_indep fs \ gs.lin_indpt_list (RAT fs)" abbreviation gso where "gso fs \ gram_schmidt_fs.gso n (RAT fs)" abbreviation \ where "\ fs \ gram_schmidt_fs.\ n (RAT fs)" abbreviation reduced where "reduced fs \ gram_schmidt_fs.reduced n (RAT fs) \" abbreviation weakly_reduced where "weakly_reduced fs \ gram_schmidt_fs.weakly_reduced n (RAT fs) \" text \lattice of initial basis\ definition "L = lattice_of fs_init" text \maximum squared norm of initial basis\ definition "N = max_list (map (nat \ sq_norm) fs_init)" text \maximum absolute value in initial basis\ definition "M = Max ({abs (fs_init ! i $ j) | i j. i < m \ j < n} \ {0})" text \This is the core invariant which enables to prove functional correctness.\ definition "\_small fs i = (\ j < i. abs (\ fs i j) \ 1/2)" +definition LLL_invariant_weak :: "int vec list \ bool" where + "LLL_invariant_weak fs = ( + gs.lin_indpt_list (RAT fs) \ + lattice_of fs = L \ + length fs = m)" + +lemma LLL_inv_wD: assumes "LLL_invariant_weak fs" + shows + "lin_indep fs" + "length (RAT fs) = m" + "set fs \ carrier_vec n" + "\ i. i < m \ fs ! i \ carrier_vec n" + "\ i. i < m \ gso fs i \ carrier_vec n" + "length fs = m" + "lattice_of fs = L" +proof (atomize (full), goal_cases) + case 1 + interpret gs': gram_schmidt_fs_lin_indpt n "RAT fs" + by (standard) (use assms LLL_invariant_weak_def gs.lin_indpt_list_def in auto) + show ?case + using assms gs'.fs_carrier gs'.f_carrier gs'.gso_carrier + by (auto simp add: LLL_invariant_weak_def gram_schmidt_fs.reduced_def) +qed + +lemma LLL_inv_wI: assumes + "set fs \ carrier_vec n" + "length fs = m" + "lattice_of fs = L" + "lin_indep fs" +shows "LLL_invariant_weak fs" + unfolding LLL_invariant_weak_def Let_def using assms by auto + definition LLL_invariant :: "bool \ nat \ int vec list \ bool" where "LLL_invariant upw i fs = ( gs.lin_indpt_list (RAT fs) \ lattice_of fs = L \ reduced fs i \ i \ m \ length fs = m \ (upw \ \_small fs i) )" +lemma LLL_inv_imp_w: "LLL_invariant upw i fs \ LLL_invariant_weak fs" + unfolding LLL_invariant_def LLL_invariant_weak_def by blast + lemma LLL_invD: assumes "LLL_invariant upw i fs" shows "lin_indep fs" "length (RAT fs) = m" "set fs \ carrier_vec n" "\ i. i < m \ fs ! i \ carrier_vec n" "\ i. i < m \ gso fs i \ carrier_vec n" "length fs = m" "lattice_of fs = L" "weakly_reduced fs i" "i \ m" "reduced fs i" "upw \ \_small fs i" proof (atomize (full), goal_cases) case 1 interpret gs': gram_schmidt_fs_lin_indpt n "RAT fs" by (standard) (use assms LLL_invariant_def gs.lin_indpt_list_def in auto) show ?case using assms gs'.fs_carrier gs'.f_carrier gs'.gso_carrier by (auto simp add: LLL_invariant_def gram_schmidt_fs.reduced_def) qed lemma LLL_invI: assumes "set fs \ carrier_vec n" "length fs = m" "lattice_of fs = L" "i \ m" "lin_indep fs" "reduced fs i" "upw \ \_small fs i" shows "LLL_invariant upw i fs" unfolding LLL_invariant_def Let_def split using assms by auto end locale fs_int' = - fixes n m fs_init \ upw i fs - assumes LLL_inv: "LLL.LLL_invariant n m fs_init \ upw i fs" + fixes n m fs_init fs + assumes LLL_inv: "LLL.LLL_invariant_weak n m fs_init fs" sublocale fs_int' \ fs_int_indpt - using LLL_inv unfolding LLL.LLL_invariant_def by (unfold_locales) blast + using LLL_inv unfolding LLL.LLL_invariant_weak_def by (unfold_locales) blast context LLL begin lemma gso_cong: assumes "\ i. i \ x \ f1 ! i = f2 ! i" "x < length f1" "x < length f2" shows "gso f1 x = gso f2 x" by (rule gs.gso_cong, insert assms, auto) lemma \_cong: assumes "\ k. j < i \ k \ j \ f1 ! k = f2 ! k" and i: "i < length f1" "i < length f2" and "j < i \ f1 ! i = f2 ! i" shows "\ f1 i j = \ f2 i j" by (rule gs.\_cong, insert assms, auto) definition reduction where "reduction = (4+\)/(4*\)" definition d :: "int vec list \ nat \ int" where "d fs k = gs.Gramian_determinant fs k" definition D :: "int vec list \ nat" where "D fs = nat (\ i < m. d fs i)" definition "d\ gs i j = int_of_rat (of_int (d gs (Suc j)) * \ gs i j)" definition logD :: "int vec list \ nat" where "logD fs = (if \ = 4/3 then (D fs) else nat (floor (log (1 / of_rat reduction) (D fs))))" definition LLL_measure :: "nat \ int vec list \ nat" where "LLL_measure i fs = (2 * logD fs + m - i)" context - fixes upw i fs - assumes Linv: "LLL_invariant upw i fs" + fixes fs + assumes Linv: "LLL_invariant_weak fs" begin -interpretation fs: fs_int' n m fs_init \ upw i fs +interpretation fs: fs_int' n m fs_init fs by (standard) (use Linv in auto) lemma Gramian_determinant: assumes k: "k \ m" shows "of_int (gs.Gramian_determinant fs k) = (\ j 0" (is ?g2) - using assms fs.Gramian_determinant LLL_invD[OF Linv] by auto + using assms fs.Gramian_determinant LLL_inv_wD[OF Linv] by auto lemma LLL_d_pos [intro]: assumes k: "k \ m" shows "d fs k > 0" - unfolding d_def using fs.Gramian_determinant k LLL_invD[OF Linv] by auto + unfolding d_def using fs.Gramian_determinant k LLL_inv_wD[OF Linv] by auto lemma LLL_d_Suc: assumes k: "k < m" shows "of_int (d fs (Suc k)) = sq_norm (gso fs k) * of_int (d fs k)" - using assms fs.fs_int_d_Suc LLL_invD[OF Linv] unfolding fs.d_def d_def by auto + using assms fs.fs_int_d_Suc LLL_inv_wD[OF Linv] unfolding fs.d_def d_def by auto lemma LLL_D_pos: shows "D fs > 0" - using fs.fs_int_D_pos LLL_invD[OF Linv] unfolding D_def fs.D_def fs.d_def d_def by auto + using fs.fs_int_D_pos LLL_inv_wD[OF Linv] unfolding D_def fs.D_def fs.d_def d_def by auto +end text \Condition when we can increase the value of $i$\ lemma increase_i: + assumes Linv: "LLL_invariant upw i fs" assumes i: "i < m" and upw: "upw \ i = 0" and red_i: "i \ 0 \ sq_norm (gso fs (i - 1)) \ \ * sq_norm (gso fs i)" shows "LLL_invariant True (Suc i) fs" "LLL_measure i fs > LLL_measure (Suc i) fs" proof - note inv = LLL_invD[OF Linv] from inv(8,10) have red: "weakly_reduced fs i" and sred: "reduced fs i" by (auto) from red red_i i have red: "weakly_reduced fs (Suc i)" unfolding gram_schmidt_fs.weakly_reduced_def by (intro allI impI, rename_tac ii, case_tac "Suc ii = i", auto) from inv(11) upw have sred_i: "\ j. j < i \ \\ fs i j\ \ 1 / 2" unfolding \_small_def by auto from sred sred_i have sred: "reduced fs (Suc i)" unfolding gram_schmidt_fs.reduced_def by (intro conjI[OF red] allI impI, rename_tac ii j, case_tac "ii = i", auto) show "LLL_invariant True (Suc i) fs" by (intro LLL_invI, insert inv red sred i, auto) show "LLL_measure i fs > LLL_measure (Suc i) fs" unfolding LLL_measure_def using i by auto qed -end - text \Standard addition step which makes $\mu_{i,j}$ small\ definition "\_small_row i fs j = (\ j'. j \ j' \ j' < i \ abs (\ fs i j') \ inverse 2)" -lemma basis_reduction_add_row_main: assumes Linv: "LLL_invariant True i fs" +lemma basis_reduction_add_row_main: assumes Linv: "LLL_invariant_weak fs" and i: "i < m" and j: "j < i" and fs': "fs' = fs[ i := fs ! i - c \\<^sub>v fs ! j]" -shows "LLL_invariant True i fs'" +shows "LLL_invariant_weak fs'" + "LLL_invariant True i fs \ LLL_invariant True i fs'" "c = round (\ fs i j) \ \_small_row i fs (Suc j) \ \_small_row i fs' j" (* mu-value at position i j gets small *) + "c = round (\ fs i j) \ abs (\ fs' i j) \ 1/2" (* mu-value at position i j gets small *) "LLL_measure i fs' = LLL_measure i fs" (* new values of gso: no change *) "\ i. i < m \ gso fs' i = gso fs i" (* new values of mu *) "\ i' j'. i' < m \ j' < m \ \ fs' i' j' = (if i' = i \ j' \ j then \ fs i j' - of_int c * \ fs j j' else \ fs i' j')" (* new values of d *) "\ ii. ii \ m \ d fs' ii = d fs ii" proof - define bnd :: rat where bnd: "bnd = 4 ^ (m - 1 - Suc j) * of_nat (N ^ (m - 1) * m)" define M where "M = map (\i. map (\ fs i) [0.. i" "j < m" and jstrict: "j < i" and add: "set fs \ carrier_vec n" "i < length fs" "j < length fs" "i \ j" - and len: "length fs = m" and red: "weakly_reduced fs i" + and len: "length fs = m" and indep: "lin_indep fs" using inv j i by auto let ?R = rat_of_int let ?RV = "map_vec ?R" from inv i j have Fij: "fs ! i \ carrier_vec n" "fs ! j \ carrier_vec n" by auto let ?x = "fs ! i - c \\<^sub>v fs ! j" let ?g = "gso fs" let ?g' = "gso fs'" let ?mu = "\ fs" let ?mu' = "\ fs'" from inv j i have Fi:"\ i. i < length (RAT fs) \ (RAT fs) ! i \ carrier_vec n" and gs_carr: "?g j \ carrier_vec n" "?g i \ carrier_vec n" "\ i. i < j \ ?g i \ carrier_vec n" "\ j. j < i \ ?g j \ carrier_vec n" and len': "length (RAT fs) = m" and add':"set (map ?RV fs) \ carrier_vec n" by auto have RAT_F1: "RAT fs' = (RAT fs)[i := (RAT fs) ! i - ?R c \\<^sub>v (RAT fs) ! j]" unfolding fs' proof (rule nth_equalityI[rule_format], goal_cases) case (2 k) show ?case proof (cases "k = i") case False thus ?thesis using 2 by auto next case True hence "?thesis = (?RV (fs ! i - c \\<^sub>v fs ! j) = ?RV (fs ! i) - ?R c \\<^sub>v ?RV (fs ! j))" using 2 add by auto also have "\" by (rule eq_vecI, insert Fij, auto) finally show ?thesis by simp qed qed auto hence RAT_F1_i:"RAT fs' ! i = (RAT fs) ! i - ?R c \\<^sub>v (RAT fs) ! j" (is "_ = _ - ?mui") using i len by auto have uminus: "fs ! i - c \\<^sub>v fs ! j = fs ! i + -c \\<^sub>v fs ! j" by (subst minus_add_uminus_vec, insert Fij, auto) have "lattice_of fs' = lattice_of fs" unfolding fs' uminus by (rule lattice_of_add[OF add, of _ "- c"], auto) with inv have lattice: "lattice_of fs' = L" by auto from add len have "k < length fs \ \ k \ i \ fs' ! k \ carrier_vec n" for k unfolding fs' by (metis (no_types, lifting) nth_list_update nth_mem subset_eq carrier_dim_vec index_minus_vec(2) index_smult_vec(2)) hence "k < length fs \ fs' ! k \ carrier_vec n" for k unfolding fs' using add len by (cases "k \ i",auto) with len have F1: "set fs' \ carrier_vec n" "length fs' = m" unfolding fs' by (auto simp: set_conv_nth) hence F1': "length (RAT fs') = m" "SRAT fs' \ Rn" by auto from indep have dist: "distinct (RAT fs)" by (auto simp: gs.lin_indpt_list_def) have Fij': "(RAT fs) ! i \ Rn" "(RAT fs) ! j \ Rn" using add'[unfolded set_conv_nth] i \j < m\ len by auto have uminus': "(RAT fs) ! i - ?R c \\<^sub>v (RAT fs) ! j = (RAT fs) ! i + - ?R c \\<^sub>v (RAT fs) ! j" by (subst minus_add_uminus_vec[where n = n], insert Fij', auto) have span_F_F1: "gs.span (SRAT fs) = gs.span (SRAT fs')" unfolding RAT_F1 uminus' by (rule gs.add_vec_span, insert len add, auto) have **: "?RV (fs ! i) + - ?R c \\<^sub>v (RAT fs) ! j = ?RV (fs ! i - c \\<^sub>v fs ! j)" by (rule eq_vecI, insert Fij len i j, auto) from i j len have "j < length (RAT fs)" "i < length (RAT fs)" "i \ j" by auto from gs.lin_indpt_list_add_vec[OF this indep, of "- of_int c"] have "gs.lin_indpt_list ((RAT fs) [i := (RAT fs) ! i + - ?R c \\<^sub>v (RAT fs) ! j])" (is "gs.lin_indpt_list ?F1") . also have "?F1 = RAT fs'" unfolding fs' using i len Fij' ** by (auto simp: map_update) finally have indep_F1: "lin_indep fs'" . have conn1: "set (RAT fs) \ carrier_vec n" "length (RAT fs) = m" "distinct (RAT fs)" "gs.lin_indpt (set (RAT fs))" using inv unfolding gs.lin_indpt_list_def by auto have conn2: "set (RAT fs') \ carrier_vec n" "length (RAT fs') = m" "distinct (RAT fs')" "gs.lin_indpt (set (RAT fs'))" using indep_F1 F1' unfolding gs.lin_indpt_list_def by auto interpret gs1: gram_schmidt_fs_lin_indpt n "RAT fs" - by (standard) (use LLL_invD[OF assms(1)] gs.lin_indpt_list_def in auto) + by (standard) (use inv gs.lin_indpt_list_def in auto) interpret gs2: gram_schmidt_fs_lin_indpt n "RAT fs'" by (standard) (use indep_F1 F1' gs.lin_indpt_list_def in auto) let ?G = "map ?g [0 ..< m]" let ?G' = "map ?g' [0 ..< m]" from gs1.span_gso gs2.span_gso gs1.gso_carrier gs2.gso_carrier conn1 conn2 span_F_F1 len have span_G_G1: "gs.span (set ?G) = gs.span (set ?G')" and lenG: "length ?G = m" and Gi: "i < length ?G \ ?G ! i \ Rn" and G1i: "i < length ?G' \ ?G' ! i \ Rn" for i by auto have eq: "x \ i \ RAT fs' ! x = (RAT fs) ! x" for x unfolding RAT_F1 by auto hence eq_part: "x < i \ ?g' x = ?g x" for x by (intro gs.gso_cong, insert len, auto) have G: "i < m \ (RAT fs) ! i \ Rn" "i < m \ fs ! i \ carrier_vec n" for i by(insert add len', auto) note carr1[intro] = this[OF i] this[OF ji(2)] have "x < m \ ?g x \ Rn" "x < m \ ?g' x \ Rn" "x < m \ dim_vec (gso fs x) = n" "x < m \ dim_vec (gso fs' x) = n" for x using inv G1i by (auto simp:o_def Gi G1i) hence carr2[intro!]:"?g i \ Rn" "?g' i \ Rn" "?g ` {0.. Rn" "?g ` {0.. Rn" using i by auto have F1_RV: "?RV (fs' ! i) = RAT fs' ! i" using i F1 by auto have F_RV: "?RV (fs ! i) = (RAT fs) ! i" using i len by auto from eq_part have span_G1_G: "gs.span (?g' ` {0.. ?rs" using gs2.oc_projection_exist[of i] conn2 i unfolding span_G1_G by auto from \j < i\ have Gj_mem: "(RAT fs) ! j \ (\ x. ((RAT fs) ! x)) ` {0 ..< i}" by auto have id1: "set (take i (RAT fs)) = (\x. ?RV (fs ! x)) ` {0..i \ m\ len + using \i < m\ len by (subst nth_image[symmetric], force+) have "(RAT fs) ! j \ ?rs \ (RAT fs) ! j \ gs.span ((\x. ?RV (fs ! x)) ` {0..i \ m\ id1 inv by auto + using gs1.partial_span \i < m\ id1 inv by auto also have "(\x. ?RV (fs ! x)) ` {0..x. ((RAT fs) ! x)) ` {0..i < m\ len by force also have "(RAT fs) ! j \ gs.span \" by (rule gs.span_mem[OF _ Gj_mem], insert \i < m\ G, auto) finally have "(RAT fs) ! j \ ?rs" . hence in2:"?mui \ ?rs" apply(intro gs.prod_in_span) by force+ have ineq:"((RAT fs) ! i - ?g' i) + ?mui - ?mui = ((RAT fs) ! i - ?g' i)" using carr1 carr2 by (intro eq_vecI, auto) have cong': "A = B \ A \ C \ B \ C" for A B :: "'a vec" and C by auto have *: "?g ` {0.. Rn" by auto have in_span: "(RAT fs) ! i - ?g' i \ ?rs" by (rule cong'[OF eq_vecI gs.span_add1[OF * in1 in2,unfolded ineq]], insert carr1 carr2, auto) { fix x assume x:"x < i" hence "x < m" "i \ x" using i by auto from gs2.orthogonal this inv assms have "?g' i \ ?g' x = 0" by auto } hence G1_G: "?g' i = ?g i" by (intro gs1.oc_projection_unique) (use inv i eq_part in_span in auto) show eq_fs:"x < m \ ?g' x = ?g x" for x proof(induct x rule:nat_less_induct[rule_format]) case (1 x) hence ind: "m < x \ ?g' m = ?g m" for m by auto { assume "x > i" hence ?case unfolding gs2.gso.simps[of x] gs1.gso.simps[of x] unfolding gs1.\.simps gs2.\.simps using ind eq by (auto intro: cong[OF _ cong[OF refl[of "gs.sumlist"]]]) } note eq_rest = this show ?case by (rule linorder_class.linorder_cases[of x i],insert G1_G eq_part eq_rest,auto) qed hence Hs:"?G' = ?G" by (auto simp:o_def) - have red: "weakly_reduced fs' i" using red using eq_fs \i < m\ + have red: "weakly_reduced fs i \ weakly_reduced fs' i" using eq_fs \i < m\ unfolding gram_schmidt_fs.weakly_reduced_def by simp let ?Mi = "M ! i ! j" have Gjn: "dim_vec (fs ! j) = n" using Fij(2) carrier_vecD by blast define E where "E = addrow_mat m (- ?R c) i j" define M' where "M' = gs1.M m" define N' where "N' = gs2.M m" have E: "E \ carrier_mat m m" unfolding E_def by simp have M: "M' \ carrier_mat m m" unfolding gs1.M_def M'_def by auto have N: "N' \ carrier_mat m m" unfolding gs2.M_def N'_def by auto let ?mat = "mat_of_rows n" let ?GsM = "?mat ?G" have Gs: "?GsM \ carrier_mat m n" by auto hence GsT: "?GsM\<^sup>T \ carrier_mat n m" by auto have Gnn: "?mat (RAT fs) \ carrier_mat m n" unfolding mat_of_rows_def using len by auto have "?mat (RAT fs') = addrow (- ?R c) i j (?mat (RAT fs))" unfolding RAT_F1 by (rule eq_matI, insert Gjn ji(2), auto simp: len mat_of_rows_def) also have "\ = E * ?mat (RAT fs)" unfolding E_def by (rule addrow_mat, insert j i, auto simp: mat_of_rows_def len) finally have HEG: "?mat (RAT fs') = E * ?mat (RAT fs)" . (* lemma 16.12(i), part 1 *) have "(E * M') * ?mat ?G = E * (M' * ?mat ?G)" by (rule assoc_mult_mat[OF E M Gs]) also have "M' * ?GsM = ?mat (RAT fs)" using gs1.matrix_equality conn1 M'_def by simp also have "E * \ = ?mat (RAT fs')" unfolding HEG .. also have "\ = N' * ?mat ?G'" using gs2.matrix_equality conn2 unfolding N'_def by simp also have "?mat ?G' = ?GsM" unfolding Hs .. finally have "(E * M') * ?GsM = N' * ?GsM" . from arg_cong[OF this, of "\ x. x * ?GsM\<^sup>T"] E M N have EMN: "(E * M') * (?GsM * ?GsM\<^sup>T) = N' * (?GsM * ?GsM\<^sup>T)" by (subst (1 2) assoc_mult_mat[OF _ Gs GsT, of _ m, symmetric], auto) have "det (?GsM * ?GsM\<^sup>T) = gs.Gramian_determinant ?G m" unfolding gs.Gramian_determinant_def by (subst gs.Gramian_matrix_alt_def, auto simp: Let_def) also have "\ > 0" proof - have 1: "gs.lin_indpt_list ?G" using conn1 gs1.orthogonal_gso gs1.gso_carrier by (intro gs.orthogonal_imp_lin_indpt_list) (auto) interpret G: gram_schmidt_fs_lin_indpt n ?G by (standard) (use 1 gs.lin_indpt_list_def in auto) show ?thesis by (intro G.Gramian_determinant) auto qed finally have "det (?GsM * ?GsM\<^sup>T) \ 0" by simp from vec_space.det_nonzero_congruence[OF EMN this _ _ N] Gs E M have EMN: "E * M' = N'" by auto (* lemma 16.12(i), part 2 *) - from inv have sred: "reduced fs i" by auto { fix i' j' assume ij: "i' < m" "j' < m" and choice: "i' \ i \ j < j'" have "?mu' i' j' = N' $$ (i',j')" using ij F1 unfolding N'_def gs2.M_def by auto also have "\ = addrow (- ?R c) i j M' $$ (i',j')" unfolding EMN[symmetric] E_def by (subst addrow_mat[OF M], insert ji, auto) also have "\ = (if i = i' then - ?R c * M' $$ (j, j') + M' $$ (i', j') else M' $$ (i', j'))" by (rule index_mat_addrow, insert ij M, auto) also have "\ = M' $$ (i', j')" proof (cases "i = i'") case True with choice have jj: "j < j'" by auto have "M' $$ (j, j') = ?mu j j'" using ij ji len unfolding M'_def gs1.M_def by auto also have "\ = 0" unfolding gs1.\.simps using jj by auto finally show ?thesis using True by auto qed auto also have "\ = ?mu i' j'" using ij len unfolding M'_def gs1.M_def by auto also note calculation } note mu_no_change = this { fix j' assume jj': "j' \ j" with j i have j': "j' < m" by auto have "?mu' i j' = N' $$ (i,j')" using jj' j i F1 unfolding N'_def gs2.M_def by auto also have "\ = addrow (- ?R c) i j M' $$ (i,j')" unfolding EMN[symmetric] E_def by (subst addrow_mat[OF M], insert ji, auto) also have "\ = - ?R c * M' $$ (j, j') + M' $$ (i, j')" by (rule index_mat_addrow, insert j' i M, auto) also have "\ = M' $$ (i, j') - ?R c * M' $$ (j, j')" by simp also have "M' $$ (i, j') = ?mu i j'" using i j' len unfolding M'_def gs1.M_def by auto also have "M' $$ (j, j') = ?mu j j'" using i j j' len unfolding M'_def gs1.M_def by auto finally have "?mu' i j' = ?mu i j' - ?R c * ?mu j j'" by auto } note mu_change = this show mu_update: "i' < m \ j' < m \ ?mu' i' j' = (if i' = i \ j' \ j then ?mu i j' - ?R c * ?mu j j' else ?mu i' j')" for i' j' using mu_change[of j'] mu_no_change[of i' j'] by auto - have sred: "reduced fs' i" - unfolding gram_schmidt_fs.reduced_def - proof (intro conjI[OF red] impI allI, goal_cases) - case (1 i' j) - with mu_no_change[of i' j] sred[unfolded gram_schmidt_fs.reduced_def, THEN conjunct2, rule_format, of i' j] i - show ?case by auto - qed + { + assume "LLL_invariant True i fs" + from LLL_invD[OF this] have "weakly_reduced fs i" and sred: "reduced fs i" by auto + from red[OF this(1)] have red: "weakly_reduced fs' i" . + have sred: "reduced fs' i" + unfolding gram_schmidt_fs.reduced_def + proof (intro conjI[OF red] impI allI, goal_cases) + case (1 i' j) + with mu_no_change[of i' j] sred[unfolded gram_schmidt_fs.reduced_def, THEN conjunct2, rule_format, of i' j] i + show ?case by auto + qed + show "LLL_invariant True i fs'" + by (intro LLL_invI[OF F1 lattice \i \ m\ indep_F1 sred], auto) + } + show Linv': "LLL_invariant_weak fs'" + by (intro LLL_inv_wI[OF F1 lattice indep_F1]) have mudiff:"?mu i j - of_int c = ?mu' i j" by (subst mu_change, auto simp: gs1.\.simps) have lin_indpt_list_fs: "gs.lin_indpt_list (RAT fs')" unfolding gs.lin_indpt_list_def using conn2 by auto { assume c: "c = round (\ fs i j)" - assume mu_small: "\_small_row i fs (Suc j)" have small: "abs (?mu i j - of_int c) \ inverse 2" unfolding j c using of_int_round_abs_le by (auto simp add: abs_minus_commute) from this[unfolded mudiff] - have mu'_2: "abs (?mu' i j) \ inverse 2" . + show mu'_2: "abs (?mu' i j) \ 1 / 2" by simp + assume mu_small: "\_small_row i fs (Suc j)" show "\_small_row i fs' j" unfolding \_small_row_def proof (intro allI, goal_cases) case (1 j') show ?case using mu'_2 mu_small[unfolded \_small_row_def, rule_format, of j'] by (cases "j' > j", insert mu_update[of i j'] i, auto) qed } - show Linv': "LLL_invariant True i fs'" - by (intro LLL_invI[OF F1 lattice \i \ m\ lin_indpt_list_fs sred], auto) { fix i assume i: "i \ m" have "rat_of_int (d fs' i) = of_int (d fs i)" unfolding d_def Gramian_determinant(1)[OF Linv i] Gramian_determinant(1)[OF Linv' i] by (rule prod.cong[OF refl], subst eq_fs, insert i, auto) thus "d fs' i = d fs i" by simp } note d = this have D: "D fs' = D fs" unfolding D_def by (rule arg_cong[of _ _ nat], rule prod.cong[OF refl], auto simp: d) show "LLL_measure i fs' = LLL_measure i fs" unfolding LLL_measure_def logD_def D .. qed text \Addition step which can be skipped since $\mu$-value is already small\ -lemma basis_reduction_add_row_main_0: assumes Linv: "LLL_invariant True i fs" +lemma basis_reduction_add_row_main_0: assumes Linv: "LLL_invariant_weak fs" and i: "i < m" and j: "j < i" and 0: "round (\ fs i j) = 0" and mu_small: "\_small_row i fs (Suc j)" shows "\_small_row i fs j" (is ?g1) proof - - note inv = LLL_invD[OF Linv] + note inv = LLL_inv_wD[OF Linv] from inv(5)[OF i] inv(5)[of j] i j have id: "fs[i := fs ! i - 0 \\<^sub>v fs ! j] = fs" by (intro nth_equalityI, insert inv i, auto) show ?g1 using basis_reduction_add_row_main[OF Linv i j _, of fs] 0 id mu_small by auto qed lemma \_small_row_refl: "\_small_row i fs i" unfolding \_small_row_def by auto lemma basis_reduction_add_row_done: assumes Linv: "LLL_invariant True i fs" and i: "i < m" and mu_small: "\_small_row i fs 0" shows "LLL_invariant False i fs" proof - note inv = LLL_invD[OF Linv] from mu_small have mu_small: "\_small fs i" unfolding \_small_row_def \_small_def by auto show ?thesis using i mu_small by (intro LLL_invI[OF inv(3,6,7,9,1,10)], auto) qed (* lemma 16.16 (ii), one case *) lemma d_swap_unchanged: assumes len: "length F1 = m" and i0: "i \ 0" and i: "i < m" and ki: "k \ i" and km: "k \ m" and swap: "F2 = F1[i := F1 ! (i - 1), i - 1 := F1 ! i]" shows "d F1 k = d F2 k" proof - let ?F1_M = "mat k n (\(i, y). F1 ! i $ y)" let ?F2_M = "mat k n (\(i, y). F2 ! i $ y)" have "\ P. P \ carrier_mat k k \ det P \ {-1, 1} \ ?F2_M = P * ?F1_M" proof cases assume ki: "k < i" hence H: "?F2_M = ?F1_M" unfolding swap by (intro eq_matI, auto) let ?P = "1\<^sub>m k" have "?P \ carrier_mat k k" "det ?P \ {-1, 1}" "?F2_M = ?P * ?F1_M" unfolding H by auto thus ?thesis by blast next assume "\ k < i" with ki have ki: "k > i" by auto let ?P = "swaprows_mat k i (i - 1)" from i0 ki have neq: "i \ i - 1" and kmi: "i - 1 < k" by auto have *: "?P \ carrier_mat k k" "det ?P \ {-1, 1}" using det_swaprows_mat[OF ki kmi neq] ki by auto from i len have iH: "i < length F1" "i - 1 < length F1" by auto have "?P * ?F1_M = swaprows i (i - 1) ?F1_M" by (subst swaprows_mat[OF _ ki kmi], auto) also have "\ = ?F2_M" unfolding swap by (intro eq_matI, rename_tac ii jj, case_tac "ii = i", (insert iH, simp add: nth_list_update)[1], case_tac "ii = i - 1", insert iH neq ki, auto simp: nth_list_update) finally show ?thesis using * by metis qed then obtain P where P: "P \ carrier_mat k k" and detP: "det P \ {-1, 1}" and H': "?F2_M = P * ?F1_M" by auto have "d F2 k = det (gs.Gramian_matrix F2 k)" unfolding d_def gs.Gramian_determinant_def by simp also have "\ = det (?F2_M * ?F2_M\<^sup>T)" unfolding gs.Gramian_matrix_def Let_def by simp also have "?F2_M * ?F2_M\<^sup>T = ?F2_M * (?F1_M\<^sup>T * P\<^sup>T)" unfolding H' by (subst transpose_mult[OF P], auto) also have "\ = P * (?F1_M * (?F1_M\<^sup>T * P\<^sup>T))" unfolding H' by (subst assoc_mult_mat[OF P], auto) also have "det \ = det P * det (?F1_M * (?F1_M\<^sup>T * P\<^sup>T))" by (rule det_mult[OF P], insert P, auto) also have "?F1_M * (?F1_M\<^sup>T * P\<^sup>T) = (?F1_M * ?F1_M\<^sup>T) * P\<^sup>T" by (subst assoc_mult_mat, insert P, auto) also have "det \ = det (?F1_M * ?F1_M\<^sup>T) * det P" by (subst det_mult, insert P, auto simp: det_transpose) also have "det (?F1_M * ?F1_M\<^sup>T) = det (gs.Gramian_matrix F1 k)" unfolding gs.Gramian_matrix_def Let_def by simp also have "\ = d F1 k" unfolding d_def gs.Gramian_determinant_def by simp finally have "d F2 k = (det P * det P) * d F1 k" by simp also have "det P * det P = 1" using detP by auto finally show "d F1 k = d F2 k" by simp qed definition base where "base = real_of_rat ((4 * \) / (4 + \))" definition g_bound :: "int vec list \ bool" where "g_bound fs = (\ i < m. sq_norm (gso fs i) \ of_nat N)" end locale LLL_with_assms = LLL + assumes \: "\ \ 4/3" and lin_dep: "lin_indep fs_init" and len: "length fs_init = m" begin lemma \0: "\ > 0" "\ \ 0" using \ by auto lemma fs_init: "set fs_init \ carrier_vec n" using lin_dep[unfolded gs.lin_indpt_list_def] by auto lemma reduction: "0 < reduction" "reduction \ 1" "\ > 4/3 \ reduction < 1" "\ = 4/3 \ reduction = 1" using \ unfolding reduction_def by auto lemma base: "\ > 4/3 \ base > 1" using reduction(1,3) unfolding reduction_def base_def by auto -lemma basis_reduction_swap_main: assumes Linv: "LLL_invariant False i fs" +lemma basis_reduction_swap_main: assumes Linvw: "LLL_invariant_weak fs" + and small: "LLL_invariant False i fs \ abs (\ fs i (i - 1)) \ 1/2" and i: "i < m" and i0: "i \ 0" and norm_ineq: "sq_norm (gso fs (i - 1)) > \ * sq_norm (gso fs i)" and fs'_def: "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" -shows "LLL_invariant False (i - 1) fs'" +shows "LLL_invariant_weak fs'" + and "LLL_invariant False i fs \ LLL_invariant False (i - 1) fs'" and "LLL_measure i fs > LLL_measure (i - 1) fs'" (* new values of gso *) and "\ k. k < m \ gso fs' k = (if k = i - 1 then gso fs i + \ fs i (i - 1) \\<^sub>v gso fs (i - 1) else if k = i then gso fs (i - 1) - (RAT fs ! (i - 1) \ gso fs' (i - 1) / sq_norm (gso fs' (i - 1))) \\<^sub>v gso fs' (i - 1) else gso fs k)" (is "\ k. _ \ _ = ?newg k") (* new values of norms of gso *) and "\ k. k < m \ sq_norm (gso fs' k) = (if k = i - 1 then sq_norm (gso fs i) + (\ fs i (i - 1) * \ fs i (i - 1)) * sq_norm (gso fs (i - 1)) else if k = i then sq_norm (gso fs i) * sq_norm (gso fs (i - 1)) / sq_norm (gso fs' (i - 1)) else sq_norm (gso fs k))" (is "\ k. _ \ _ = ?new_norm k") (* new values of \-values *) and "\ ii j. ii < m \ j < ii \ \ fs' ii j = ( if ii = i - 1 then \ fs i j else if ii = i then if j = i - 1 then \ fs i (i - 1) * sq_norm (gso fs (i - 1)) / sq_norm (gso fs' (i - 1)) else \ fs (i - 1) j else if ii > i \ j = i then \ fs ii (i - 1) - \ fs i (i - 1) * \ fs ii i else if ii > i \ j = i - 1 then \ fs ii (i - 1) * \ fs' i (i - 1) + \ fs ii i * sq_norm (gso fs i) / sq_norm (gso fs' (i - 1)) else \ fs ii j)" (is "\ ii j. _ \ _ \ _ = ?new_mu ii j") (* new d-values *) and "\ ii. ii \ m \ of_int (d fs' ii) = (if ii = i then sq_norm (gso fs' (i - 1)) / sq_norm (gso fs (i - 1)) * of_int (d fs i) else of_int (d fs ii))" proof - - note inv = LLL_invD[OF Linv] - interpret fs: fs_int' n m fs_init \ False i fs - by (standard) (use Linv in auto) + note inv = LLL_inv_wD[OF Linvw] + interpret fs: fs_int' n m fs_init fs + by (standard) (use Linvw in auto) let ?mu1 = "\ fs" let ?mu2 = "\ fs'" let ?g1 = "gso fs" let ?g2 = "gso fs'" - from inv(11)[unfolded \_small_def] - have mu_F1_i: "\ j. j \?mu1 i j\ \ 1 / 2" by auto - from mu_F1_i[of "i-1"] have m12: "\?mu1 i (i - 1)\ \ inverse 2" using i0 - by auto + have m12: "\?mu1 i (i - 1)\ \ inverse 2" using small + proof + assume "LLL_invariant False i fs" + from LLL_invD(11)[OF this] i0 show ?thesis unfolding \_small_def by auto + qed auto note d = d_def note Gd = Gramian_determinant(1) - note Gd12 = Gd[OF Linv] + note Gd12 = Gd[OF Linvw] let ?x = "?g1 (i - 1)" let ?y = "?g1 i" let ?cond = "\ * sq_norm ?y < sq_norm ?x" - from inv have red: "weakly_reduced fs i" - and len: "length fs = m" and HC: "set fs \ carrier_vec n" + from inv have len: "length fs = m" and HC: "set fs \ carrier_vec n" and L: "lattice_of fs = L" using i by auto from i0 inv i have swap: "set fs \ carrier_vec n" "i < length fs" "i - 1 < length fs" "i \ i - 1" unfolding Let_def by auto have RAT_fs': "RAT fs' = (RAT fs)[i := (RAT fs) ! (i - 1), i - 1 := (RAT fs) ! i]" unfolding fs'_def using swap by (intro nth_equalityI, auto simp: nth_list_update) have span': "gs.span (SRAT fs) = gs.span (SRAT fs')" unfolding fs'_def by (rule arg_cong[of _ _ gs.span], insert swap, auto) have lfs': "lattice_of fs' = lattice_of fs" unfolding fs'_def by (rule lattice_of_swap[OF swap refl]) with inv have lattice: "lattice_of fs' = L" by auto have len': "length fs' = m" using inv unfolding fs'_def by auto have fs': "set fs' \ carrier_vec n" using swap unfolding fs'_def set_conv_nth by (auto, rename_tac k, case_tac "k = i", force, case_tac "k = i - 1", auto) let ?rv = "map_vec rat_of_int" from inv(1) have indepH: "lin_indep fs" . from i i0 len have "i < length (RAT fs)" "i - 1 < length (RAT fs)" by auto with distinct_swap[OF this] len have "distinct (RAT fs') = distinct (RAT fs)" unfolding RAT_fs' by (auto simp: map_update) with len' fs' span' indepH have indepH': "lin_indep fs'" unfolding fs'_def using i i0 by (auto simp: gs.lin_indpt_list_def) have lenR': "length (RAT fs') = m" using len' by auto have conn1: "set (RAT fs) \ carrier_vec n" "length (RAT fs) = m" "distinct (RAT fs)" "gs.lin_indpt (set (RAT fs))" using inv unfolding gs.lin_indpt_list_def by auto have conn2: "set (RAT fs') \ carrier_vec n" "length (RAT fs') = m" "distinct (RAT fs')" "gs.lin_indpt (set (RAT fs'))" using indepH' lenR' unfolding gs.lin_indpt_list_def by auto interpret gs2: gram_schmidt_fs_lin_indpt n "RAT fs'" by (standard) (use indepH' lenR' gs.lin_indpt_list_def in auto) have fs'_fs: "k < i - 1 \ fs' ! k = fs ! k" for k unfolding fs'_def by auto { fix k assume ki: "k < i - 1" with i have kn: "k < m" by simp have "?g2 k = ?g1 k" by (rule gs.gso_cong, insert ki kn len, auto simp: fs'_def) } note G2_G = this have take_eq: "take (Suc i - 1 - 1) fs' = take (Suc i - 1 - 1) fs" by (intro nth_equalityI, insert len len' i swap(2-), auto intro!: fs'_fs) - from inv have "weakly_reduced fs i" by auto - hence "weakly_reduced fs (i - 1)" unfolding gram_schmidt_fs.weakly_reduced_def by auto - hence red: "weakly_reduced fs' (i - 1)" - unfolding gram_schmidt_fs.weakly_reduced_def using i G2_G by simp have i1n: "i - 1 < m" using i by auto let ?R = rat_of_int let ?RV = "map_vec ?R" let ?f1 = "\ i. RAT fs ! i" let ?f2 = "\ i. RAT fs' ! i" let ?n1 = "\ i. sq_norm (?g1 i)" let ?n2 = "\ i. sq_norm (?g2 i)" have heq:"fs ! (i - 1) = fs' ! i" "take (i-1) fs = take (i-1) fs'" "?f2 (i - 1) = ?f1 i" "?f2 i = ?f1 (i - 1)" unfolding fs'_def using i len i0 by auto have norm_pos2: "j < m \ ?n2 j > 0" for j using gs2.sq_norm_pos len' by simp have norm_pos1: "j < m \ ?n1 j > 0" for j using fs.gs.sq_norm_pos inv by simp have norm_zero2: "j < m \ ?n2 j \ 0" for j using norm_pos2[of j] by linarith have norm_zero1: "j < m \ ?n1 j \ 0" for j using norm_pos1[of j] by linarith have gs: "\ j. j < m \ ?g1 j \ Rn" using inv by blast have gs2: "\ j. j < m \ ?g2 j \ Rn" using fs.gs.gso_carrier conn2 by auto have g: "\ j. j < m \ ?f1 j \ Rn" using inv by auto have g2: "\ j. j < m \ ?f2 j \ Rn" using gs2.f_carrier conn2 by blast let ?fs1 = "?f1 ` {0..< (i - 1)}" have G: "?fs1 \ Rn" using g i by auto let ?gs1 = "?g1 ` {0..< (i - 1)}" have G': "?gs1 \ Rn" using gs i by auto let ?S = "gs.span ?fs1" let ?S' = "gs.span ?gs1" have S'S: "?S' = ?S" by (rule fs.gs.partial_span', insert conn1 i, auto) have "gs.is_oc_projection (?g2 (i - 1)) (gs.span (?g2 ` {0..< (i - 1)})) (?f2 (i - 1))" using i len' by (intro gs2.gso_oc_projection_span(2)) auto also have "?f2 (i - 1) = ?f1 i" unfolding fs'_def using len i by auto also have "gs.span (?g2 ` {0 ..< (i - 1)}) = gs.span (?f2 ` {0 ..< (i - 1)})" using i len' by (intro gs2.partial_span') auto also have "?f2 ` {0 ..< (i - 1)} = ?fs1" by (rule image_cong[OF refl], insert len i, auto simp: fs'_def) finally have claim1: "gs.is_oc_projection (?g2 (i - 1)) ?S (?f1 i)" . have list_id: "[0..j. ?mu1 i j \\<^sub>v ?g1 j) [0 ..< i]) + ?g1 i" (is "_ = ?sum + _") apply(subst fs.gs.fi_is_sum_of_mu_gso, insert len i, force) unfolding map_append list_id by (subst gs.M.sumlist_snoc, insert i gs conn1, auto simp: fs.gs.\.simps) have f1im1_sum: "?f1 (i - 1) = gs.sumlist (map (\j. ?mu1 (i - 1) j \\<^sub>v ?g1 j) [0...simps) have sum: "?sum \ Rn" by (rule gs.sumlist_carrier, insert gs i, auto) have sum1: "?sum1 \ Rn" by (rule gs.sumlist_carrier, insert gs i, auto) from gs.span_closed[OF G] have S: "?S \ Rn" by auto from gs i have gs': "\ j. j < i - 1 \ ?g1 j \ Rn" and gsi: "?g1 (i - 1) \ Rn" by auto have "[0 ..< i] = [0 ..< Suc (i - 1)]" using i0 by simp also have "\ = [0 ..< i - 1] @ [i - 1]" by simp finally have list: "[0 ..< i] = [0 ..< i - 1] @ [i - 1]" . { (* d does not change for k \ i *) fix k assume kn: "k \ m" and ki: "k \ i" from d_swap_unchanged[OF len i0 i ki kn fs'_def] have "d fs k = d fs' k" by simp } note d = this (* new value of g (i-1) *) have g2_im1: "?g2 (i - 1) = ?g1 i + ?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1)" (is "_ = _ + ?mu_f1") proof (rule gs.is_oc_projection_eq[OF claim1 _ S g[OF i]]) show "gs.is_oc_projection (?g1 i + ?mu_f1) ?S (?f1 i)" unfolding gs.is_oc_projection_def proof (intro conjI allI impI) let ?sum' = "gs.sumlist (map (\j. ?mu1 i j \\<^sub>v ?g1 j) [0 ..< i - 1])" have sum': "?sum' \ Rn" by (rule gs.sumlist_carrier, insert gs i, auto) show inRn: "(?g1 i + ?mu_f1) \ Rn" using gs[OF i] gsi i by auto have carr: "?sum \ Rn" "?g1 i \ Rn" "?mu_f1 \ Rn" "?sum' \ Rn" using sum' sum gs[OF i] gsi i by auto have "?f1 i - (?g1 i + ?mu_f1) = (?sum + ?g1 i) - (?g1 i + ?mu_f1)" unfolding f1i_sum by simp also have "\ = ?sum - ?mu_f1" using carr by auto also have "?sum = gs.sumlist (map (\j. ?mu1 i j \\<^sub>v ?g1 j) [0 ..< i - 1] @ [?mu_f1])" unfolding list by simp also have "\ = ?sum' + ?mu_f1" by (subst gs.sumlist_append, insert gs' gsi, auto) also have "\ - ?mu_f1 = ?sum'" using sum' gsi by auto finally have id: "?f1 i - (?g1 i + ?mu_f1) = ?sum'" . show "?f1 i - (?g1 i + ?mu_f1) \ gs.span ?S" unfolding id gs.span_span[OF G] proof (rule gs.sumlist_in_span[OF G]) fix v assume "v \ set (map (\j. ?mu1 i j \\<^sub>v ?g1 j) [0 ..< i - 1])" then obtain j where j: "j < i - 1" and v: "v = ?mu1 i j \\<^sub>v ?g1 j" by auto show "v \ ?S" unfolding v by (rule gs.smult_in_span[OF G], unfold S'S[symmetric], rule gs.span_mem, insert gs i j, auto) qed fix x assume "x \ ?S" hence x: "x \ ?S'" using S'S by simp show "(?g1 i + ?mu_f1) \ x = 0" proof (rule gs.orthocompl_span[OF _ G' inRn x]) fix x assume "x \ ?gs1" then obtain j where j: "j < i - 1" and x_id: "x = ?g1 j" by auto from j i x_id gs[of j] have x: "x \ Rn" by auto { fix k assume k: "k > j" "k < m" have "?g1 k \ x = 0" unfolding x_id by (rule fs.gs.orthogonal, insert conn1 k, auto) } from this[of i] this[of "i - 1"] j i have main: "?g1 i \ x = 0" "?g1 (i - 1) \ x = 0" by auto have "(?g1 i + ?mu_f1) \ x = ?g1 i \ x + ?mu_f1 \ x" by (rule add_scalar_prod_distrib[OF gs[OF i] _ x], insert gsi, auto) also have "\ = 0" using main by (subst smult_scalar_prod_distrib[OF gsi x], auto) finally show "(?g1 i + ?mu_f1) \ x = 0" . qed qed qed { (* 16.13 (i): for g, only g_i and g_{i-1} can change *) fix k assume kn: "k < m" and ki: "k \ i" "k \ i - 1" have "?g2 k = gs.oc_projection (gs.span (?g2 ` {0..i") case True hence "k < i - 1" using ki by auto then show ?thesis apply(intro image_cong) unfolding fs'_def using len i by auto next case False have "?f2 ` {0.. = ?f1 ` {0.. = gs.span (?g1 ` {0.. = ?g1 k" by (subst fs.gs.gso_oc_projection_span, insert kn conn1, auto) finally have "?g2 k = ?g1 k" . } note g2_g1_identical = this (* calculation of new mu-values *) { (* no change of mu for lines before line i - 1 *) fix jj ii assume ii: "ii < i - 1" have "?mu2 ii jj = ?mu1 ii jj" using ii i len by (subst gs.\_cong[of _ _ "RAT fs" "RAT fs'"], auto simp: fs'_def) } note mu'_mu_small_i = this { (* swap of mu-values in lines i - 1 and i for j < i - 1 *) fix jj assume jj: "jj < i - 1" hence id1: "jj < i - 1 \ True" "jj < i \ True" by auto have id2: "?g2 jj = ?g1 jj" by (subst g2_g1_identical, insert jj i, auto) have "?mu2 i jj = ?mu1 (i - 1) jj" "?mu2 (i - 1) jj = ?mu1 i jj" unfolding gs2.\.simps fs.gs.\.simps id1 id2 if_True using len i i0 by (auto simp: fs'_def) } note mu'_mu_i_im1_j = this have im1: "i - 1 < m" using i by auto (* calculation of new value of g_i *) let ?g2_im1 = "?g2 (i - 1)" have g2_im1_Rn: "?g2_im1 \ Rn" using i conn2 by (auto intro!: fs.gs.gso_carrier) { let ?mu2_f2 = "\ j. - ?mu2 i j \\<^sub>v ?g2 j" let ?sum = "gs.sumlist (map (\j. - ?mu1 (i - 1) j \\<^sub>v ?g1 j) [0 ..< i - 1])" have mhs: "?mu2_f2 (i - 1) \ Rn" using i conn2 by (auto intro!: fs.gs.gso_carrier) have sum': "?sum \ Rn" by (rule gs.sumlist_carrier, insert gs i, auto) have gim1: "?f1 (i - 1) \ Rn" using g i by auto have "?g2 i = ?f2 i + gs.sumlist (map ?mu2_f2 [0 ..< i-1] @ [?mu2_f2 (i-1)])" unfolding gs2.gso.simps[of i] list by simp also have "?f2 i = ?f1 (i - 1)" unfolding fs'_def using len i i0 by auto also have "map ?mu2_f2 [0 ..< i-1] = map (\j. - ?mu1 (i - 1) j \\<^sub>v ?g1 j) [0 ..< i - 1]" by (rule map_cong[OF refl], subst g2_g1_identical, insert i, auto simp: mu'_mu_i_im1_j) also have "gs.sumlist (\ @ [?mu2_f2 (i - 1)]) = ?sum + ?mu2_f2 (i - 1)" by (subst gs.sumlist_append, insert gs i mhs, auto) also have "?f1 (i - 1) + \ = (?f1 (i - 1) + ?sum) + ?mu2_f2 (i - 1)" using gim1 sum' mhs by auto also have "?f1 (i - 1) + ?sum = ?g1 (i - 1)" unfolding fs.gs.gso.simps[of "i - 1"] by simp also have "?mu2_f2 (i - 1) = - (?f2 i \ ?g2_im1 / sq_norm ?g2_im1) \\<^sub>v ?g2_im1" unfolding gs2.\.simps using i0 by simp also have "\ = - ((?f2 i \ ?g2_im1 / sq_norm ?g2_im1) \\<^sub>v ?g2_im1)" by auto also have "?g1 (i - 1) + \ = ?g1 (i - 1) - ((?f2 i \ ?g2_im1 / sq_norm ?g2_im1) \\<^sub>v ?g2_im1)" by (rule sym, rule minus_add_uminus_vec[of _ n], insert gsi g2_im1_Rn, auto) also have "?f2 i = ?f1 (i - 1)" by fact finally have "?g2 i = ?g1 (i - 1) - (?f1 (i - 1) \ ?g2 (i - 1) / sq_norm (?g2 (i - 1))) \\<^sub>v ?g2 (i - 1)" . } note g2_i = this let ?n1 = "\ i. sq_norm (?g1 i)" let ?n2 = "\ i. sq_norm (?g2 i)" (* calculation of new norms *) { (* norm of g (i - 1) *) have "?n2 (i - 1) = sq_norm (?g1 i + ?mu_f1)" unfolding g2_im1 by simp also have "\ = (?g1 i + ?mu_f1) \ (?g1 i + ?mu_f1)" by (simp add: sq_norm_vec_as_cscalar_prod) also have "\ = (?g1 i + ?mu_f1) \ ?g1 i + (?g1 i + ?mu_f1) \ ?mu_f1" by (rule scalar_prod_add_distrib, insert gs i, auto) also have "(?g1 i + ?mu_f1) \ ?g1 i = ?g1 i \ ?g1 i + ?mu_f1 \ ?g1 i" by (rule add_scalar_prod_distrib, insert gs i, auto) also have "(?g1 i + ?mu_f1) \ ?mu_f1 = ?g1 i \ ?mu_f1 + ?mu_f1 \ ?mu_f1" by (rule add_scalar_prod_distrib, insert gs i, auto) also have "?mu_f1 \ ?g1 i = ?g1 i \ ?mu_f1" by (rule comm_scalar_prod, insert gs i, auto) also have "?g1 i \ ?g1 i = sq_norm (?g1 i)" by (simp add: sq_norm_vec_as_cscalar_prod) also have "?g1 i \ ?mu_f1 = ?mu1 i (i - 1) * (?g1 i \ ?g1 (i - 1))" by (rule scalar_prod_smult_right, insert gs[OF i] gs[OF \i - 1 < m\], auto) also have "?g1 i \ ?g1 (i - 1) = 0" using orthogonalD[OF fs.gs.orthogonal_gso, of i "i - 1"] i len i0 by (auto simp: o_def) also have "?mu_f1 \ ?mu_f1 = ?mu1 i (i - 1) * (?mu_f1 \ ?g1 (i - 1))" by (rule scalar_prod_smult_right, insert gs[OF i] gs[OF \i - 1 < m\], auto) also have "?mu_f1 \ ?g1 (i - 1) = ?mu1 i (i - 1) * (?g1 (i - 1) \ ?g1 (i - 1))" by (rule scalar_prod_smult_left, insert gs[OF i] gs[OF \i - 1 < m\], auto) also have "?g1 (i - 1) \ ?g1 (i - 1) = sq_norm (?g1 (i - 1))" by (simp add: sq_norm_vec_as_cscalar_prod) finally have "?n2 (i - 1) = ?n1 i + (?mu1 i (i - 1) * ?mu1 i (i - 1)) * ?n1 (i - 1)" by (simp add: ac_simps o_def) } note sq_norm_g2_im1 = this from norm_pos1[OF i] norm_pos1[OF im1] norm_pos2[OF i] norm_pos2[OF im1] have norm0: "?n1 i \ 0" "?n1 (i - 1) \ 0" "?n2 i \ 0" "?n2 (i - 1) \ 0" by auto hence norm0': "?n2 (i - 1) \ 0" using i by auto { (* new norm of g i *) have si: "Suc i \ m" and im1: "i - 1 \ m" using i by auto have det1: "gs.Gramian_determinant (RAT fs) (Suc i) = (\jfs.gs.gso j\\<^sup>2)" using fs.gs.Gramian_determinant si len by auto have det2: "gs.Gramian_determinant (RAT fs') (Suc i) = (\jgs2.gso j\\<^sup>2)" using gs2.Gramian_determinant si len' by auto from norm_zero1[OF less_le_trans[OF _ im1]] have 0: "(\j < i-1. ?n1 j) \ 0" by (subst prod_zero_iff, auto) have "rat_of_int (d fs' (Suc i)) = rat_of_int (d fs (Suc i))" using d_swap_unchanged[OF len i0 i _ si fs'_def] by auto also have "rat_of_int (d fs' (Suc i)) = gs.Gramian_determinant (RAT fs') (Suc i)" unfolding d_def by (subst fs.of_int_Gramian_determinant[symmetric], insert conn2 i g fs', auto simp: set_conv_nth) also have "\ = (\j = (\jj\ ?set. ?n2 j) = ?n2 i * ?n2 (i - 1) * (\j < i-1. ?n2 j)" using i0 by (subst prod.insert; (subst prod.insert)?; auto) also have "(\j\ ?set. ?n1 j) = ?n1 i * ?n1 (i - 1) * (\j < i-1. ?n1 j)" using i0 by (subst prod.insert; (subst prod.insert)?; auto) also have "(\j < i-1. ?n2 j) = (\j < i-1. ?n1 j)" by (rule prod.cong, insert G2_G, auto) finally have "?n2 i = ?n1 i * ?n1 (i - 1) / ?n2 (i - 1)" using 0 norm0' by (auto simp: field_simps) } note sq_norm_g2_i = this (* mu values in rows > i do not change with j \ {i, i - 1} *) { fix ii j assume ii: "ii > i" "ii < m" and ji: "j \ i" "j \ i - 1" { assume j: "j < ii" have "?mu2 ii j = (?f2 ii \ ?g2 j) / sq_norm (?g2 j)" unfolding gs2.\.simps using j by auto also have "?f2 ii = ?f1 ii" using ii len unfolding fs'_def by auto also have "?g2 j = ?g1 j" using g2_g1_identical[of j] j ii ji by auto finally have "?mu2 ii j = ?mu1 ii j" unfolding fs.gs.\.simps using j by auto } hence "?mu2 ii j = ?mu1 ii j" by (cases "j < ii", auto simp: gs2.\.simps fs.gs.\.simps) } note mu_no_change_large_row = this { (* the new value of mu i (i - 1) *) have "?mu2 i (i - 1) = (?f2 i \ ?g2 (i - 1)) / ?n2 (i - 1)" unfolding gs2.\.simps using i0 by auto also have "?f2 i \ ?g2 (i - 1) = ?f1 (i - 1) \ ?g2 (i - 1)" using len i i0 unfolding fs'_def by auto also have "\ = ?f1 (i - 1) \ (?g1 i + ?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1))" unfolding g2_im1 by simp also have "\ = ?f1 (i - 1) \ ?g1 i + ?f1 (i - 1) \ (?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1))" by (rule scalar_prod_add_distrib[of _ n], insert i gs g, auto) also have "?f1 (i - 1) \ ?g1 i = 0" by (subst fs.gs.fi_scalar_prod_gso, insert conn1 im1 i i0, auto simp: fs.gs.\.simps fs.gs.\.simps) also have "?f1 (i - 1) \ (?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1)) = ?mu1 i (i - 1) * (?f1 (i - 1) \ ?g1 (i - 1))" by (rule scalar_prod_smult_distrib, insert gs g i, auto) also have "?f1 (i - 1) \ ?g1 (i - 1) = ?n1 (i - 1)" by (subst fs.gs.fi_scalar_prod_gso, insert conn1 im1, auto simp: fs.gs.\.simps) finally have "?mu2 i (i - 1) = ?mu1 i (i - 1) * ?n1 (i - 1) / ?n2 (i - 1)" by (simp add: sq_norm_vec_as_cscalar_prod) } note mu'_mu_i_im1 = this { (* the new values of mu ii (i - 1) for ii > i *) fix ii assume iii: "ii > i" and ii: "ii < m" hence iii1: "i - 1 < ii" by auto have "?mu2 ii (i - 1) = (?f2 ii \ ?g2 (i - 1)) / ?n2 (i - 1)" unfolding gs2.\.simps using i0 iii1 by auto also have "?f2 ii \ ?g2 (i-1) = ?f1 ii \ ?g2 (i - 1)" using len i i0 iii ii unfolding fs'_def by auto also have "\ = ?f1 ii \ (?g1 i + ?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1))" unfolding g2_im1 by simp also have "\ = ?f1 ii \ ?g1 i + ?f1 ii \ (?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1))" by (rule scalar_prod_add_distrib[of _ n], insert i ii gs g, auto) also have "?f1 ii \ ?g1 i = ?mu1 ii i * ?n1 i" by (rule fs.gs.fi_scalar_prod_gso, insert conn1 ii i, auto) also have "?f1 ii \ (?mu1 i (i - 1) \\<^sub>v ?g1 (i - 1)) = ?mu1 i (i - 1) * (?f1 ii \ ?g1 (i - 1))" by (rule scalar_prod_smult_distrib, insert gs g i ii, auto) also have "?f1 ii \ ?g1 (i - 1) = ?mu1 ii (i - 1) * ?n1 (i - 1)" by (rule fs.gs.fi_scalar_prod_gso, insert conn1 ii im1, auto) finally have "?mu2 ii (i - 1) = ?mu1 ii (i - 1) * ?mu2 i (i - 1) + ?mu1 ii i * ?n1 i / ?n2 (i - 1)" unfolding mu'_mu_i_im1 using norm0 by (auto simp: field_simps) } note mu'_mu_large_row_im1 = this { (* the new values of mu ii i for ii > i *) fix ii assume iii: "ii > i" and ii: "ii < m" have "?mu2 ii i = (?f2 ii \ ?g2 i) / ?n2 i" unfolding gs2.\.simps using i0 iii by auto also have "?f2 ii \ ?g2 i = ?f1 ii \ ?g2 i" using len i i0 iii ii unfolding fs'_def by auto also have "\ = ?f1 ii \ (?g1 (i - 1) - (?f1 (i - 1) \ ?g2 (i - 1) / ?n2 (i - 1)) \\<^sub>v ?g2 (i - 1))" unfolding g2_i by simp also have "?f1 (i - 1) = ?f2 i" using i i0 len unfolding fs'_def by auto also have "?f2 i \ ?g2 (i - 1) / ?n2 (i - 1) = ?mu2 i (i - 1)" unfolding gs2.\.simps using i i0 by auto also have "?f1 ii \ (?g1 (i - 1) - ?mu2 i (i - 1) \\<^sub>v ?g2 (i - 1)) = ?f1 ii \ ?g1 (i - 1) - ?f1 ii \ (?mu2 i (i - 1) \\<^sub>v ?g2 (i - 1))" by (rule scalar_prod_minus_distrib[OF g gs], insert gs2 ii i, auto) also have "?f1 ii \ ?g1 (i - 1) = ?mu1 ii (i - 1) * ?n1 (i - 1)" by (rule fs.gs.fi_scalar_prod_gso, insert conn1 ii im1, auto) also have "?f1 ii \ (?mu2 i (i - 1) \\<^sub>v ?g2 (i - 1)) = ?mu2 i (i - 1) * (?f1 ii \ ?g2 (i - 1))" by (rule scalar_prod_smult_distrib, insert gs gs2 g i ii, auto) also have "?f1 ii \ ?g2 (i - 1) = (?f1 ii \ ?g2 (i - 1) / ?n2 (i - 1)) * ?n2 (i - 1)" using norm0 by (auto simp: field_simps) also have "?f1 ii \ ?g2 (i - 1) = ?f2 ii \ ?g2 (i - 1)" using len ii iii unfolding fs'_def by auto also have "\ / ?n2 (i - 1) = ?mu2 ii (i - 1)" unfolding gs2.\.simps using iii by auto finally have "?mu2 ii i = (?mu1 ii (i - 1) * ?n1 (i - 1) - ?mu2 i (i - 1) * ?mu2 ii (i - 1) * ?n2 (i - 1)) / ?n2 i" by simp also have "\ = (?mu1 ii (i - 1) - ?mu1 i (i - 1) * ?mu2 ii (i - 1)) * ?n2 (i - 1) / ?n1 i" unfolding sq_norm_g2_i mu'_mu_i_im1 using norm0 by (auto simp: field_simps) also have "\ = (?mu1 ii (i - 1) * ?n2 (i - 1) - ?mu1 i (i - 1) * ((?mu1 ii i * ?n1 i + ?mu1 i (i - 1) * ?mu1 ii (i - 1) * ?n1 (i - 1)))) / ?n1 i" unfolding mu'_mu_large_row_im1[OF iii ii] mu'_mu_i_im1 using norm0 by (auto simp: field_simps) also have "\ = ?mu1 ii (i - 1) - ?mu1 i (i - 1) * ?mu1 ii i" unfolding sq_norm_g2_im1 using norm0 by (auto simp: field_simps) finally have "?mu2 ii i = ?mu1 ii (i - 1) - ?mu1 i (i - 1) * ?mu1 ii i" . } note mu'_mu_large_row_i = this { fix k assume k: "k < m" show "?g2 k = ?newg k" unfolding g2_i[symmetric] unfolding g2_im1[symmetric] using g2_g1_identical[OF k] by auto show "?n2 k = ?new_norm k" unfolding sq_norm_g2_i[symmetric] unfolding sq_norm_g2_im1[symmetric] using g2_g1_identical[OF k] by auto fix j assume jk: "j < k" hence j: "j < m" using k by auto have "k < i - 1 \ k = i - 1 \ k = i \ k > i" by linarith thus "?mu2 k j = ?new_mu k j" unfolding mu'_mu_i_im1[symmetric] using mu'_mu_large_row_i[OF _ k] mu'_mu_large_row_im1 [OF _ k] mu_no_change_large_row[OF _ k, of j] mu'_mu_small_i mu'_mu_i_im1_j jk j k by auto } note new_g = this - (* stay reduced *) - from inv have sred: "reduced fs i" by auto - have sred: "reduced fs' (i - 1)" - unfolding gram_schmidt_fs.reduced_def - proof (intro conjI[OF red] allI impI, goal_cases) - case (1 i' j) - with sred have "\?mu1 i' j\ \ 1 / 2" unfolding gram_schmidt_fs.reduced_def by auto - thus ?case using mu'_mu_small_i[OF 1(1)] by simp - qed - { (* 16.13 (ii) : norm of g (i - 1) decreases by reduction factor *) note sq_norm_g2_im1 also have "?n1 i + (?mu1 i (i - 1) * ?mu1 i (i - 1)) * ?n1 (i - 1) < 1/\ * (?n1 (i - 1)) + (1/2 * 1/2) * (?n1 (i - 1))" proof (rule add_less_le_mono[OF _ mult_mono]) from norm_ineq[unfolded mult.commute[of \], THEN linordered_field_class.mult_imp_less_div_pos[OF \0(1)]] show "?n1 i < 1/\ * ?n1 (i - 1)" using len i by auto from m12 have abs: "abs (?mu1 i (i - 1)) \ 1/2" by auto have "?mu1 i (i - 1) * ?mu1 i (i - 1) \ abs (?mu1 i (i - 1)) * abs (?mu1 i (i - 1))" by auto also have "\ \ 1/2 * 1/2" using mult_mono[OF abs abs] by auto finally show "?mu1 i (i - 1) * ?mu1 i (i - 1) \ 1/2 * 1/2" by auto qed auto also have "\ = reduction * sq_norm (?g1 (i - 1))" unfolding reduction_def using \0 by (simp add: ring_distribs add_divide_distrib) finally have "?n2 (i - 1) < reduction * ?n1 (i - 1)" . } note g_reduction = this (* Lemma 16.13 (ii) *) have lin_indpt_list_fs': "gs.lin_indpt_list (RAT fs')" unfolding gs.lin_indpt_list_def using conn2 by auto - have mu_small: "\_small fs' (i - 1)" - unfolding \_small_def - proof (intro allI impI, goal_cases) - case (1 j) - thus ?case using inv(11) unfolding mu'_mu_i_im1_j[OF 1] \_small_def by auto - qed + { + (* stay reduced *) + assume "LLL_invariant False i fs" + note inv = LLL_invD[OF this] + from inv have "weakly_reduced fs i" by auto + hence "weakly_reduced fs (i - 1)" unfolding gram_schmidt_fs.weakly_reduced_def by auto + hence red: "weakly_reduced fs' (i - 1)" + unfolding gram_schmidt_fs.weakly_reduced_def using i G2_G by simp + from inv have sred: "reduced fs i" by auto + have sred: "reduced fs' (i - 1)" + unfolding gram_schmidt_fs.reduced_def + proof (intro conjI[OF red] allI impI, goal_cases) + case (1 i' j) + with sred have "\?mu1 i' j\ \ 1 / 2" unfolding gram_schmidt_fs.reduced_def by auto + thus ?case using mu'_mu_small_i[OF 1(1)] by simp + qed + have mu_small: "\_small fs' (i - 1)" + unfolding \_small_def + proof (intro allI impI, goal_cases) + case (1 j) + thus ?case using inv(11) unfolding mu'_mu_i_im1_j[OF 1] \_small_def by auto + qed + show "LLL_invariant False (i - 1) fs'" + by (rule LLL_invI, insert lin_indpt_list_fs' conn2 mu_small span' lattice fs' sred i, auto) + } + (* invariant is established *) - show newInv: "LLL_invariant False (i - 1) fs'" - by (rule LLL_invI, insert lin_indpt_list_fs' conn2 mu_small span' lattice fs' sred i, auto) + show newInvw: "LLL_invariant_weak fs'" + by (rule LLL_inv_wI, insert lin_indpt_list_fs' conn2 span' lattice fs', auto) (* show decrease in measure *) { (* 16.16 (ii), the decreasing case *) have ile: "i \ m" using i by auto - from Gd[OF newInv, folded d_def, OF ile] + from Gd[OF newInvw, folded d_def, OF ile] have "?R (d fs' i) = (\j = prod ?n2 ({0 ..< i-1} \ {i - 1})" by (rule sym, rule prod.cong, (insert i0, auto)[1], insert i, auto) also have "\ = ?n2 (i - 1) * prod ?n2 ({0 ..< i-1})" by simp also have "prod ?n2 ({0 ..< i-1}) = prod ?n1 ({0 ..< i-1})" by (rule prod.cong[OF refl], subst g2_g1_identical, insert i, auto) also have "\ = (prod ?n1 ({0 ..< i-1} \ {i - 1})) / ?n1 (i - 1)" by (subst prod.union_disjoint, insert norm_pos1[OF im1], auto) also have "prod ?n1 ({0 ..< i-1} \ {i - 1}) = prod ?n1 {0.. = (\j = ?R (d fs i)" unfolding d_def Gd[OF Linv ile] + also have "\ = ?R (d fs i)" unfolding d_def Gd[OF Linvw ile] by (rule prod.cong[OF refl], insert i, auto) finally have new_di: "?R (d fs' i) = ?n2 (i - 1) / ?n1 (i - 1) * ?R (d fs i)" by simp also have "\ < (reduction * ?n1 (i - 1)) / ?n1 (i - 1) * ?R (d fs i)" by (rule mult_strict_right_mono[OF divide_strict_right_mono[OF g_reduction norm_pos1[OF im1]]], - insert LLL_d_pos[OF Linv] i, auto) + insert LLL_d_pos[OF Linvw] i, auto) also have "\ = reduction * ?R (d fs i)" using norm_pos1[OF im1] by auto finally have "d fs' i < real_of_rat reduction * d fs i" using of_rat_less of_rat_mult of_rat_of_int_eq by metis note this new_di } note d_i = this show "ii \ m \ ?R (d fs' ii) = (if ii = i then ?n2 (i - 1) / ?n1 (i - 1) * ?R (d fs i) else ?R (d fs ii))" for ii using d_i d by auto have pos: "k < m \ 0 < d fs' k" "k < m \ 0 \ d fs' k" for k - using LLL_d_pos[OF newInv, of k] by auto + using LLL_d_pos[OF newInvw, of k] by auto have prodpos:"0< (\ix\{0.. (\x\{0..iaii j \ {0 ..< m} - {i} \ {i}. d fs' j)" by (rule prod.cong, insert i, auto) also have "real_of_int \ = real_of_int (\ j \ {0 ..< m} - {i}. d fs' j) * real_of_int (d fs' i)" by (subst prod.union_disjoint, auto) also have "\ < (\ j \ {0 ..< m} - {i}. d fs' j) * (of_rat reduction * d fs i)" by(rule mult_strict_left_mono[OF d_i(1)],insert prod_pos',auto) also have "(\ j \ {0 ..< m} - {i}. d fs' j) = (\ j \ {0 ..< m} - {i}. d fs j)" by (rule prod.cong, insert d, auto) also have "\ * (of_rat reduction * d fs i) = of_rat reduction * (\ j \ {0 ..< m} - {i} \ {i}. d fs j)" by (subst prod.union_disjoint, auto) also have "(\ j \ {0 ..< m} - {i} \ {i}. d fs j) = (\ j = 4/3") case True show ?thesis using D unfolding reduction(4)[OF True] logD_def unfolding True by simp next case False hence False': "\ = 4/3 \ False" by simp from False \ have "\ > 4/3" by simp with reduction have reduction1: "reduction < 1" by simp let ?new = "real (D fs')" let ?old = "real (D fs)" let ?log = "log (1/of_rat reduction)" - note pos = LLL_D_pos[OF newInv] LLL_D_pos[OF assms(1)] + note pos = LLL_D_pos[OF newInvw] LLL_D_pos[OF Linvw] from reduction have "real_of_rat reduction > 0" by auto hence gediv:"1/real_of_rat reduction > 0" by auto have "(1/of_rat reduction) * ?new \ ((1/of_rat reduction) * of_rat reduction) * ?old" unfolding mult.assoc real_mult_le_cancel_iff2[OF gediv] using D by simp also have "(1/of_rat reduction) * of_rat reduction = 1" using reduction by auto finally have "(1/of_rat reduction) * ?new \ ?old" by auto hence "?log ((1/of_rat reduction) * ?new) \ ?log ?old" by (subst log_le_cancel_iff, auto simp: pos reduction1 reduction) hence "floor (?log ((1/of_rat reduction) * ?new)) \ floor (?log ?old)" by (rule floor_mono) hence "nat (floor (?log ((1/of_rat reduction) * ?new))) \ nat (floor (?log ?old))" by simp also have "\ = logD fs" unfolding logD_def False' by simp also have "?log ((1/of_rat reduction) * ?new) = 1 + ?log ?new" by (subst log_mult, insert reduction reduction1, auto simp: pos ) also have "floor (1 + ?log ?new) = 1 + floor (?log ?new)" by simp also have "nat (1 + floor (?log ?new)) = 1 + nat (floor (?log ?new))" by (subst nat_add_distrib, insert pos reduction reduction1, auto) also have "nat (floor (?log ?new)) = logD fs'" unfolding logD_def False' by simp finally show "logD fs' < logD fs" by simp qed show "LLL_measure i fs > LLL_measure (i - 1) fs'" unfolding LLL_measure_def using i logD by simp qed lemma LLL_inv_initial_state: "LLL_invariant True 0 fs_init" proof - from lin_dep[unfolded gs.lin_indpt_list_def] have "set (RAT fs_init) \ Rn" by auto hence fs_init: "set fs_init \ carrier_vec n" by auto show ?thesis by (rule LLL_invI[OF fs_init len _ _ lin_dep], auto simp: L_def gs.reduced_def gs.weakly_reduced_def) qed lemma LLL_inv_m_imp_reduced: assumes "LLL_invariant True m fs" shows "reduced fs m" using LLL_invD[OF assms] by blast lemma basis_reduction_short_vector: assumes LLL_inv: "LLL_invariant True m fs" and v: "v = hd fs" and m0: "m \ 0" shows "v \ carrier_vec n" "v \ L - {0\<^sub>v n}" "h \ L - {0\<^sub>v n} \ rat_of_int (sq_norm v) \ \ ^ (m - 1) * rat_of_int (sq_norm h)" "v \ 0\<^sub>v j" proof - let ?L = "lattice_of fs_init" have a1: "\ \ 1" using \ by auto from LLL_invD[OF LLL_inv] have L: "lattice_of fs = L" and red: "gram_schmidt_fs.weakly_reduced n (RAT fs) \ (length (RAT fs))" and basis: "lin_indep fs" and lenH: "length fs = m" and H: "set fs \ carrier_vec n" by (auto simp: gs.lin_indpt_list_def gs.reduced_def) from lin_dep have G: "set fs_init \ carrier_vec n" unfolding gs.lin_indpt_list_def by auto with m0 len have "dim_vec (hd fs_init) = n" by (cases fs_init, auto) from v m0 lenH v have v: "v = fs ! 0" by (cases fs, auto) interpret gs1: gram_schmidt_fs_lin_indpt n "RAT fs" by (standard) (use assms LLL_invariant_def gs.lin_indpt_list_def in auto) let ?r = "rat_of_int" let ?rv = "map_vec ?r" let ?F = "RAT fs" let ?h = "?rv h" { assume h:"h \ L - {0\<^sub>v n}" (is ?h_req) from h[folded L] have h: "h \ lattice_of fs" "h \ 0\<^sub>v n" by auto { assume f: "?h = 0\<^sub>v n" have "?h = ?rv (0\<^sub>v n)" unfolding f by (intro eq_vecI, auto) hence "h = 0\<^sub>v n" using of_int_hom.vec_hom_zero_iff[of h] of_int_hom.vec_hom_inj by auto with h have False by simp } hence h0: "?h \ 0\<^sub>v n" by auto with lattice_of_of_int[OF H h(1)] have "?h \ gs.lattice_of ?F - {0\<^sub>v n}" by auto } from gs1.weakly_reduced_imp_short_vector[OF red this a1] lenH show "h \ L - {0\<^sub>v n} \ ?r (sq_norm v) \ \ ^ (m - 1) * ?r (sq_norm h)" using basis unfolding L v gs.lin_indpt_list_def by (auto simp: sq_norm_of_int) from m0 H lenH show vn: "v \ carrier_vec n" unfolding v by (cases fs, auto) have vL: "v \ L" unfolding L[symmetric] v using m0 H lenH by (intro basis_in_latticeI, cases fs, auto) { assume "v = 0\<^sub>v n" hence "hd ?F = 0\<^sub>v n" unfolding v using m0 lenH by (cases fs, auto) with gs.lin_indpt_list_nonzero[OF basis] have False using m0 lenH by (cases fs, auto) } with vL show v: "v \ L - {0\<^sub>v n}" by auto have jn:"0\<^sub>v j \ carrier_vec n \ j = n" unfolding zero_vec_def carrier_vec_def by auto with v vn show "v \ 0\<^sub>v j" by auto qed -lemma LLL_mu_d_Z: assumes inv: "LLL_invariant upw i fs" +lemma LLL_mu_d_Z: assumes inv: "LLL_invariant_weak fs" and j: "j \ ii" and ii: "ii < m" shows "of_int (d fs (Suc j)) * \ fs ii j \ \" proof - - interpret fs: fs_int' n m fs_init \ upw i fs + interpret fs: fs_int' n m fs_init fs by standard (use inv in auto) show ?thesis - using assms fs.fs_int_mu_d_Z LLL_invD[OF inv] unfolding d_def fs.d_def by auto + using assms fs.fs_int_mu_d_Z LLL_inv_wD[OF inv] unfolding d_def fs.d_def by auto qed -context fixes upw i fs - assumes Linv: "LLL_invariant upw i fs" and gbnd: "g_bound fs" +context fixes fs + assumes Linv: "LLL_invariant_weak fs" and gbnd: "g_bound fs" begin interpretation gs1: gram_schmidt_fs_lin_indpt n "RAT fs" - by (standard) (use Linv LLL_invariant_def gs.lin_indpt_list_def in auto) + by (standard) (use Linv LLL_invariant_weak_def gs.lin_indpt_list_def in auto) lemma LLL_inv_N_pos: assumes m: "m \ 0" shows "N > 0" proof - let ?r = rat_of_int - note inv = LLL_invD[OF Linv] + note inv = LLL_inv_wD[OF Linv] from inv have F: "RAT fs ! 0 \ Rn" "fs ! 0 \ carrier_vec n" using m by auto from m have upt: "[0..< m] = 0 # [1 ..< m]" using upt_add_eq_append[of 0 1 "m - 1"] by auto from inv(6) m have "map_vec ?r (fs ! 0) \ 0\<^sub>v n" using gs.lin_indpt_list_nonzero[OF inv(1)] unfolding set_conv_nth by force hence F0: "fs ! 0 \ 0\<^sub>v n" by auto hence "sq_norm (fs ! 0) \ 0" using F by simp hence 1: "sq_norm (fs ! 0) \ 1" using sq_norm_vec_ge_0[of "fs ! 0"] by auto from gbnd m have "sq_norm (gso fs 0) \ of_nat N" unfolding g_bound_def by auto also have "gso fs 0 = RAT fs ! 0" unfolding upt using F by (simp add: gs1.gso.simps[of 0]) also have "RAT fs ! 0 = map_vec ?r (fs ! 0)" using inv(6) m by auto also have "sq_norm \ = ?r (sq_norm (fs ! 0))" by (simp add: sq_norm_of_int) finally show ?thesis using 1 by (cases N, auto) qed (* equation (3) in front of Lemma 16.18 *) lemma d_approx_main: assumes i: "ii \ m" "m \ 0" shows "rat_of_int (d fs ii) \ rat_of_nat (N^ii)" proof - - note inv = LLL_invD[OF Linv] + note inv = LLL_inv_wD[OF Linv] from LLL_inv_N_pos i have A: "0 < N" by auto note main = inv(2)[unfolded gram_schmidt_int_def gram_schmidt_wit_def] have "rat_of_int (d fs ii) = (\jgso fs j\\<^sup>2)" unfolding d_def using i by (auto simp: Gramian_determinant [OF Linv]) also have "\ \ (\j = (of_nat N)^ii" unfolding prod_constant by simp also have "\ = of_nat (N^ii)" by simp finally show ?thesis by simp qed lemma d_approx: assumes i: "ii < m" shows "rat_of_int (d fs ii) \ rat_of_nat (N^ii)" using d_approx_main[of ii] assms by auto lemma d_bound: assumes i: "ii < m" shows "d fs ii \ N^ii" using d_approx[OF assms] unfolding d_def by linarith lemma D_approx: "D fs \ N ^ (m * m)" proof - - note inv = LLL_invD[OF Linv] + note inv = LLL_inv_wD[OF Linv] from LLL_inv_N_pos have N: "m \ 0 \ 0 < N" by auto note main = inv(2)[unfolded gram_schmidt_int_def gram_schmidt_wit_def] have "rat_of_int (\ii \ (\i \ (\i = (of_nat N)^(m * m)" unfolding prod_constant power_mult by simp also have "\ = of_nat (N ^ (m * m))" by simp finally have "(\i N ^ (m * m)" by linarith also have "(\i N ^ (m * m)" by linarith qed lemma LLL_measure_approx: assumes "\ > 4/3" "m \ 0" shows "LLL_measure i fs \ m + 2 * m * m * log base N" proof - have b1: "base > 1" using base assms by auto have id: "base = 1 / real_of_rat reduction" unfolding base_def reduction_def using \0 by (auto simp: field_simps of_rat_divide) from LLL_D_pos[OF Linv] have D1: "real (D fs) \ 1" by auto - note invD = LLL_invD[OF Linv] + note invD = LLL_inv_wD[OF Linv] from invD have F: "set fs \ carrier_vec n" and len: "length fs = m" by auto have N0: "N > 0" using LLL_inv_N_pos[OF assms(2)] . from D_approx have D: "D fs \ N ^ (m * m)" . hence "real (D fs) \ real (N ^ (m * m))" by linarith also have "\ = real N ^ (m * m)" by simp finally have log: "log base (real (D fs)) \ log base (real N ^ (m * m))" by (subst log_le_cancel_iff[OF b1], insert D1 N0, auto) have "real (logD fs) = real (nat \log base (real (D fs))\)" unfolding logD_def id using assms by auto also have "\ \ log base (real (D fs))" using b1 D1 by auto also have "\ \ log base (real N ^ (m * m))" by fact also have "\ = (m * m) * log base (real N)" by (rule log_nat_power, insert N0, auto) finally have main: "logD fs \ m * m * log base N" by simp have "real (LLL_measure i fs) = real (2 * logD fs + m - i)" unfolding LLL_measure_def split invD(1) by simp also have "\ \ 2 * real (logD fs) + m" using invD by simp also have "\ \ 2 * (m * m * log base N) + m" using main by auto finally show ?thesis by simp qed end lemma g_bound_fs_init: "g_bound fs_init" proof - { fix i assume i: "i < m" let ?N = "map (nat o sq_norm) fs_init" let ?r = rat_of_int from i have mem: "nat (sq_norm (fs_init ! i)) \ set ?N" using fs_init len unfolding set_conv_nth by force interpret gs: gram_schmidt_fs_lin_indpt n "RAT fs_init" by (standard) (use len lin_dep LLL_invariant_def gs.lin_indpt_list_def in auto) from mem_set_imp_le_max_list[OF _ mem] have FN: "nat (sq_norm (fs_init ! i)) \ N" unfolding N_def by force hence "\fs_init ! i\\<^sup>2 \ int N" using i by auto also have "\ \ int (N * m)" using i by fastforce finally have f_bnd: "\fs_init ! i\\<^sup>2 \ int (N * m)" . from FN have "rat_of_nat (nat (sq_norm (fs_init ! i))) \ rat_of_nat N" by simp also have "rat_of_nat (nat (sq_norm (fs_init ! i))) = ?r (sq_norm (fs_init ! i))" using sq_norm_vec_ge_0[of "fs_init ! i"] by auto also have "\ = sq_norm (RAT fs_init ! i)" unfolding sq_norm_of_int[symmetric] using fs_init len i by auto finally have "sq_norm (RAT fs_init ! i) \ rat_of_nat N" . with gs.sq_norm_gso_le_f i len lin_dep have g_bnd: "\gs.gso i\\<^sup>2 \ rat_of_nat N" unfolding gs.lin_indpt_list_def by fastforce note f_bnd g_bnd } thus "g_bound fs_init" unfolding g_bound_def by auto qed lemma LLL_measure_approx_fs_init: "LLL_invariant upw i fs_init \ 4 / 3 < \ \ m \ 0 \ real (LLL_measure i fs_init) \ real m + real (2 * m * m) * log base (real N)" - using LLL_measure_approx[OF _ g_bound_fs_init] . + using LLL_measure_approx[OF LLL_inv_imp_w g_bound_fs_init] . lemma N_le_MMn: assumes m0: "m \ 0" shows "N \ nat M * nat M * n" unfolding N_def proof (rule max_list_le, unfold set_map o_def) fix ni assume "ni \ (\x. nat \x\\<^sup>2) ` set fs_init" then obtain fi where ni: "ni = nat (\fi\\<^sup>2)" and fi: "fi \ set fs_init" by auto from fi len obtain i where fii: "fi = fs_init ! i" and i: "i < m" unfolding set_conv_nth by auto from fi fs_init have fi: "fi \ carrier_vec n" by auto let ?set = "{\fs_init ! i $ j\ |i j. i < m \ j < n} \ {0}" have id: "?set = (\ (i,j). abs (fs_init ! i $ j)) ` ({0.. {0.. {0}" by force have fin: "finite ?set" unfolding id by auto { fix j assume "j < n" hence "M \ \fs_init ! i $ j\" unfolding M_def using i by (intro Max_ge[of _ "abs (fs_init ! i $ j)"], intro fin, auto) } note M = this from Max_ge[OF fin, of 0] have M0: "M \ 0" unfolding M_def by auto have "ni = nat (\fi\\<^sup>2)" unfolding ni by auto also have "\ \ nat (int n * \fi\\<^sub>\\<^sup>2)" using sq_norm_vec_le_linf_norm[OF fi] by (intro nat_mono, auto) also have "\ = n * nat (\fi\\<^sub>\\<^sup>2)" by (simp add: nat_mult_distrib) also have "\ \ n * nat (M^2)" proof (rule mult_left_mono[OF nat_mono]) have fi: "\fi\\<^sub>\ \ M" unfolding linf_norm_vec_def proof (rule max_list_le, unfold set_append set_map, rule ccontr) fix x assume "x \ abs ` set (list_of_vec fi) \ set [0]" and xM: "\ x \ M" with M0 obtain fij where fij: "fij \ set (list_of_vec fi)" and x: "x = abs fij" by auto from fij fi obtain j where j: "j < n" and fij: "fij = fi $ j" unfolding set_list_of_vec vec_set_def by auto from M[OF j] xM[unfolded x fij fii] show False by auto qed auto show "\fi\\<^sub>\\<^sup>2 \ M^2" unfolding abs_le_square_iff[symmetric] using fi using linf_norm_vec_ge_0[of fi] by auto qed auto finally show "ni \ nat M * nat M * n" using M0 by (subst nat_mult_distrib[symmetric], auto simp: power2_eq_square ac_simps) qed (insert m0 len, auto) subsection \Basic LLL implementation based on previous results\ text \We now assemble a basic implementation of the LLL algorithm, where only the lattice basis is updated, and where the GSO and the $\mu$-values are always computed from scratch. This enables a simple soundness proof and permits to separate an efficient implementation from the soundness reasoning.\ fun basis_reduction_add_rows_loop where "basis_reduction_add_rows_loop i fs 0 = fs" | "basis_reduction_add_rows_loop i fs (Suc j) = ( let c = round (\ fs i j); fs' = (if c = 0 then fs else fs[ i := fs ! i - c \\<^sub>v fs ! j]) in basis_reduction_add_rows_loop i fs' j)" definition basis_reduction_add_rows where "basis_reduction_add_rows upw i fs = (if upw then basis_reduction_add_rows_loop i fs i else fs)" definition basis_reduction_swap where "basis_reduction_swap i fs = (False, i - 1, fs[i := fs ! (i - 1), i - 1 := fs ! i])" definition basis_reduction_step where "basis_reduction_step upw i fs = (if i = 0 then (True, Suc i, fs) else let fs' = basis_reduction_add_rows upw i fs in if sq_norm (gso fs' (i - 1)) \ \ * sq_norm (gso fs' i) then (True, Suc i, fs') else basis_reduction_swap i fs')" function basis_reduction_main where "basis_reduction_main (upw,i,fs) = (if i < m \ LLL_invariant upw i fs then basis_reduction_main (basis_reduction_step upw i fs) else fs)" by pat_completeness auto definition "reduce_basis = basis_reduction_main (True, 0, fs_init)" definition "short_vector = hd reduce_basis" text \Soundness of this implementation is easily proven\ lemma basis_reduction_add_rows_loop: assumes inv: "LLL_invariant True i fs" and mu_small: "\_small_row i fs j" and res: "basis_reduction_add_rows_loop i fs j = fs'" and i: "i < m" and j: "j \ i" shows "LLL_invariant False i fs'" "LLL_measure i fs' = LLL_measure i fs" proof (atomize(full), insert assms, induct j arbitrary: fs) case (0 fs) thus ?case using basis_reduction_add_row_done[of i fs] by auto next case (Suc j fs) hence j: "j < i" by auto let ?c = "round (\ fs i j)" show ?case proof (cases "?c = 0") case True - thus ?thesis using Suc(1)[OF Suc(2) basis_reduction_add_row_main_0[OF Suc(2) i j True Suc(3)]] + thus ?thesis using Suc(1)[OF Suc(2) basis_reduction_add_row_main_0[OF LLL_inv_imp_w[OF Suc(2)] i j True Suc(3)]] Suc(2-) by auto next case False - note step = basis_reduction_add_row_main[OF Suc(2) i j refl] - show ?thesis using Suc(1)[OF step(1-2)] False Suc(2-) step(3) by auto + note step = basis_reduction_add_row_main(2-)[OF LLL_inv_imp_w[OF Suc(2)] i j refl] + note step = step(1)[OF Suc(2)] step(2-) + show ?thesis using Suc(1)[OF step(1-2)] False Suc(2-) step(4) by simp qed qed lemma basis_reduction_add_rows: assumes inv: "LLL_invariant upw i fs" and res: "basis_reduction_add_rows upw i fs = fs'" and i: "i < m" shows "LLL_invariant False i fs'" "LLL_measure i fs' = LLL_measure i fs" proof (atomize(full), goal_cases) case 1 note def = basis_reduction_add_rows_def show ?case proof (cases upw) case False with res inv show ?thesis by (simp add: def) next case True with inv have "LLL_invariant True i fs" by auto note start = this \_small_row_refl[of i fs] from res[unfolded def] True have "basis_reduction_add_rows_loop i fs i = fs'" by auto from basis_reduction_add_rows_loop[OF start this i] show ?thesis by auto qed qed lemma basis_reduction_swap: assumes inv: "LLL_invariant False i fs" and res: "basis_reduction_swap i fs = (upw',i',fs')" and cond: "sq_norm (gso fs (i - 1)) > \ * sq_norm (gso fs i)" and i: "i < m" "i \ 0" shows "LLL_invariant upw' i' fs'" (is ?g1) "LLL_measure i' fs' < LLL_measure i fs" (is ?g2) proof - + note invw = LLL_inv_imp_w[OF inv] note def = basis_reduction_swap_def from res[unfolded basis_reduction_swap_def] have id: "upw' = False" "i' = i - 1" "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" by auto - from basis_reduction_swap_main(1-2)[OF inv i cond id(3)] show ?g1 ?g2 unfolding id by auto + from basis_reduction_swap_main(2-3)[OF invw _ i cond id(3)] inv show ?g1 ?g2 unfolding id by auto qed lemma basis_reduction_step: assumes inv: "LLL_invariant upw i fs" and res: "basis_reduction_step upw i fs = (upw',i',fs')" and i: "i < m" shows "LLL_invariant upw' i' fs'" "LLL_measure i' fs' < LLL_measure i fs" proof (atomize(full), goal_cases) case 1 note def = basis_reduction_step_def + note invw = LLL_inv_imp_w[OF inv] obtain fs'' where fs'': "basis_reduction_add_rows upw i fs = fs''" by auto show ?case proof (cases "i = 0") case True - from increase_i[OF inv i True] True + from increase_i[OF inv i] True res show ?thesis by (auto simp: def) next case False hence id: "(i = 0) = False" by auto note res = res[unfolded def id if_False fs'' Let_def] let ?x = "sq_norm (gso fs'' (i - 1))" let ?y = "\ * sq_norm (gso fs'' i)" from basis_reduction_add_rows[OF inv fs'' i] have inv: "LLL_invariant False i fs''" and meas: "LLL_measure i fs'' = LLL_measure i fs" by auto + note invw = LLL_inv_imp_w[OF inv] show ?thesis proof (cases "?x \ ?y") case True - from increase_i[OF inv i _ True] True res meas - show ?thesis by auto + from increase_i[OF inv i] id True res meas + show ?thesis by simp next case gt: False hence "?x > ?y" by auto from basis_reduction_swap[OF inv _ this i False] gt res meas show ?thesis by auto qed qed qed termination by (relation "measure (\ (upw,i,fs). LLL_measure i fs)", insert basis_reduction_step, auto split: prod.splits) declare basis_reduction_main.simps[simp del] lemma basis_reduction_main: assumes "LLL_invariant upw i fs" and res: "basis_reduction_main (upw,i,fs) = fs'" shows "LLL_invariant True m fs'" using assms proof (induct "LLL_measure i fs" arbitrary: i fs upw rule: less_induct) case (less i fs upw) have id: "LLL_invariant upw i fs = True" using less by auto note res = less(3)[unfolded basis_reduction_main.simps[of upw i fs] id] note inv = less(2) note IH = less(1) show ?case proof (cases "i < m") case i: True obtain i' fs' upw' where step: "basis_reduction_step upw i fs = (upw',i',fs')" (is "?step = _") by (cases ?step, auto) from IH[OF basis_reduction_step(2,1)[OF inv step i]] res[unfolded step] i show ?thesis by auto next case False with LLL_invD[OF inv] have i: "i = m" by auto with False res inv have "LLL_invariant upw m fs'" by auto thus "LLL_invariant True m fs'" unfolding LLL_invariant_def by auto qed qed lemma reduce_basis_inv: assumes res: "reduce_basis = fs" shows "LLL_invariant True m fs" using basis_reduction_main[OF LLL_inv_initial_state res[unfolded reduce_basis_def]] . lemma reduce_basis: assumes res: "reduce_basis = fs" shows "lattice_of fs = L" "reduced fs m" "lin_indep fs" "length fs = m" using LLL_invD[OF reduce_basis_inv[OF res]] by blast+ lemma short_vector: assumes res: "short_vector = v" and m0: "m \ 0" shows "v \ carrier_vec n" "v \ L - {0\<^sub>v n}" "h \ L - {0\<^sub>v n} \ rat_of_int (sq_norm v) \ \ ^ (m - 1) * rat_of_int (sq_norm h)" "v \ 0\<^sub>v j" using basis_reduction_short_vector[OF reduce_basis_inv[OF refl] res[symmetric, unfolded short_vector_def] m0] by blast+ end end diff --git a/thys/LLL_Basis_Reduction/LLL_Complexity.thy b/thys/LLL_Basis_Reduction/LLL_Complexity.thy --- a/thys/LLL_Basis_Reduction/LLL_Complexity.thy +++ b/thys/LLL_Basis_Reduction/LLL_Complexity.thy @@ -1,700 +1,700 @@ (* Authors: Maximilian Haslbeck René Thiemann License: BSD *) subsection \Bound on Number of Arithmetic Operations for Integer Implementation\ text \In this section we define a version of the LLL algorithm which explicitly returns the costs of running the algorithm. Its soundness is mainly proven by stating that projecting away yields the original result. The cost model counts the number of arithmetic operations that occur in vector-addition, scalar-products, and scalar multiplication and we prove a polynomial bound on this number.\ theory LLL_Complexity imports LLL_Impl Cost "HOL-Library.Discrete" begin definition round_num_denom_cost :: "int \ int \ int cost" where "round_num_denom_cost n d = ((2 * n + d) div (2 * d), 4)" \ \4 arith. operations\ lemma round_num_denom_cost: shows "result (round_num_denom_cost n d) = round_num_denom n d" "cost (round_num_denom_cost n d) \ 4" unfolding round_num_denom_cost_def round_num_denom_def by (auto simp: cost_simps) context LLL_with_assms begin context assumes \_gt: "\ > 4/3" and m0: "m \ 0" begin fun basis_reduction_add_rows_loop_cost where "basis_reduction_add_rows_loop_cost state i j [] = (state, 0)" | "basis_reduction_add_rows_loop_cost state i sj (fj # fjs) = ( let fi = fi_state state; dsj = d_state state sj; j = sj - 1; (c,cost1) = round_num_denom_cost (dmu_ij_state state i j) dsj; state' = (if c = 0 then state else upd_fi_mu_state state i (vec n (\ i. fi $ i - c * fj $ i)) \ \2n arith. operations\ (IArray.of_fun (\ jj. let mu = dmu_ij_state state i jj in \ \3 sj arith. operations\ if jj < j then mu - c * dmu_ij_state state j jj else if jj = j then mu - dsj * c else mu) i)); local_cost = 2 * n + 3 * sj; (res,cost2) = basis_reduction_add_rows_loop_cost state' i j fjs in (res, cost1 + local_cost + cost2))" lemma basis_reduction_add_rows_loop_cost: assumes "length fs = j" shows "result (basis_reduction_add_rows_loop_cost state i j fs) = LLL_Impl.basis_reduction_add_rows_loop n state i j fs" "cost (basis_reduction_add_rows_loop_cost state i j fs) \ sum (\ j. (2 * n + 4 + 3 * (Suc j))) {0.. 4" by auto obtain st where st: "(if fc = 0 then state else upd_fi_mu_state state i (vec n (\ i. fi_state state $ i - fc * fj $ i)) (IArray.of_fun (\jj. if jj < j - 1 then dmu_ij_state state i jj - fc * dmu_ij_state state (j - 1) jj else if jj = j - 1 then dmu_ij_state state i jj - d_state state j * fc else dmu_ij_state state i jj) i)) = st" by auto obtain res c2 where rec: "basis_reduction_add_rows_loop_cost st i (j - 1) fs = (res,c2)" (is "?x = _") by (cases ?x, auto) from Cons(2) have "length fs = j - 1" by auto from result_costD'[OF Cons(1)[OF this] rec] have res: "LLL_Impl.basis_reduction_add_rows_loop n st i (j - 1) fs = res" and c2: "c2 \ (\j = 0.. (\j = 0.. = (\j = 0.. (2 * n + 2 * i + 7) * i" proof (atomize (full), goal_cases) case 1 note d = basis_reduction_add_rows_cost_def LLL_Impl.basis_reduction_add_rows_def show ?case proof (cases upw) case False thus ?thesis by (auto simp: d cost_simps) next case True hence upw: "upw = True" by simp obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto) from to_list_repr[OF impl inv state] have len: "length (small_fs_state state) = i" unfolding small_fs_state.simps state list_repr_def by auto let ?call = "basis_reduction_add_rows_cost upw i state" have res: "result ?call = LLL_Impl.basis_reduction_add_rows n upw i state" and cost: "cost ?call \ sum (\ j. (2 * n + 4 + 3 * (Suc j))) {0.. j. (2 * n + 4 + 3 * (Suc j))) {0..j = 0..j = 0.. (2 * n + 7) * i + 3 * (i * (i - 1) div 2)" . also have "\ \ (2 * n + 7) * i + 2 * i * i" proof (rule add_left_mono) have "3 * (i * (i - 1) div 2) \ 2 * i * (i - 1)" by simp also have "\ \ 2 * i * i" by (intro mult_mono, auto) finally show "3 * (i * (i - 1) div 2) \ 2 * i * i" . qed also have "\ = (2 * n + 2 * i + 7) * i" by (simp add: algebra_simps) finally have cost: "cost ?call \ (2 * n + 2 * i + 7) * i" . show ?thesis using res cost by simp qed qed definition swap_mu_cost :: "int iarray iarray \ nat \ int \ int \ int \ int \ int iarray iarray cost" where "swap_mu_cost dmu i dmu_i_im1 dim1 di dsi = (let im1 = i - 1; res = IArray.of_fun (\ ii. if ii < im1 then dmu !! ii else if ii > i then let dmu_ii = dmu !! ii in IArray.of_fun (\ j. let dmu_ii_j = dmu_ii !! j in \ \8 arith. operations for whole line\ if j = i then (dsi * dmu_ii !! im1 - dmu_i_im1 * dmu_ii_j) div di \ \4 arith. operations for this entry\ else if j = im1 then (dmu_i_im1 * dmu_ii_j + dmu_ii !! i * dim1) div di \ \4 arith. operations for this entry\ else dmu_ii_j) ii else if ii = i then let mu_im1 = dmu !! im1 in IArray.of_fun (\ j. if j = im1 then dmu_i_im1 else mu_im1 !! j) ii else IArray.of_fun (\ j. dmu !! i !! j) ii) \ \ii = i - 1\ m; \ \in total, there are m - (i+1) many lines that require arithmetic operations: i + 1, ..., m - 1\ cost = 8 * (m - Suc i) in (res,cost))" lemma swap_mu_cost: "result (swap_mu_cost dmu i dmu_i_im1 dim1 di dsi) = swap_mu m dmu i dmu_i_im1 dim1 di dsi" "cost (swap_mu_cost dmu i dmu_i_im1 dim1 di dsi) \ 8 * (m - Suc i)" by (auto simp: swap_mu_cost_def swap_mu_def Let_def cost_simps) definition basis_reduction_swap_cost where "basis_reduction_swap_cost i state = (let di = d_state state i; dsi = d_state state (Suc i); dim1 = d_state state (i - 1); fi = fi_state state; fim1 = fim1_state state; dmu_i_im1 = dmu_ij_state state i (i - 1); fi' = fim1; fim1' = fi; di' = (dsi * dim1 + dmu_i_im1 * dmu_i_im1) div di; \ \4 arith. operations\ local_cost = 4 in (case state of (f,dmus,djs) \ case swap_mu_cost dmus i dmu_i_im1 dim1 di dsi of (swap_res, swap_cost) \ let res = (False, i - 1, (dec_i (update_im1 (update_i f fi') fim1'), swap_res, iarray_update djs i di')); cost = local_cost + swap_cost in (res, cost)))" lemma basis_reduction_swap_cost: "result (basis_reduction_swap_cost i state) = LLL_Impl.basis_reduction_swap m i state" "cost (basis_reduction_swap_cost i state) \ 8 * (m - Suc i) + 4" proof (atomize(full), goal_cases) case 1 obtain f dmus djs where state: "state = (f,dmus,djs)" by (cases state, auto) let ?mu = "dmu_ij_state (f, dmus, djs) i (i - 1)" let ?di1 = "d_state (f, dmus, djs) (i - 1)" let ?di = "d_state (f, dmus, djs) i" let ?dsi = "d_state (f, dmus, djs) (Suc i)" show ?case unfolding basis_reduction_swap_cost_def LLL_Impl.basis_reduction_swap_def Let_def state split using swap_mu_cost[of dmus i ?mu ?di1 ?di ?dsi] by (cases "swap_mu_cost dmus i ?mu ?di1 ?di ?dsi", auto simp: cost_simps) qed definition basis_reduction_step_cost where "basis_reduction_step_cost upw i state = (if i = 0 then ((True, Suc i, inc_state state), 0) else let (state',cost_add) = basis_reduction_add_rows_cost upw i state; di = d_state state' i; dsi = d_state state' (Suc i); dim1 = d_state state' (i - 1); (num,denom) = quotient_of \; cond = (di * di * denom \ num * dim1 * dsi); \ \5 arith. operations\ local_cost = 5 in if cond then ((True, Suc i, inc_state state'), local_cost + cost_add) else case basis_reduction_swap_cost i state' of (res, cost_swap) \ (res, local_cost + cost_swap + cost_add))" definition "body_cost = 2 + (8 + 2 * n + 2 * m) * m" lemma basis_reduction_step_cost: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and i: "i < m" shows "result (basis_reduction_step_cost upw i state) = LLL_Impl.basis_reduction_step \ n m upw i state" (is ?g1) "cost (basis_reduction_step_cost upw i state) \ body_cost" (is ?g2) proof - obtain state' c_add where add: "basis_reduction_add_rows_cost upw i state = (state',c_add)" (is "?add = _") by (cases ?add, auto) obtain state'' c_swap where swapc: "basis_reduction_swap_cost i state' = (state'',c_swap)" (is "?swap = _") by (cases ?swap, auto) note res = basis_reduction_step_cost_def[of upw i state, unfolded add split swap] from result_costD[OF basis_reduction_add_rows_cost[OF impl inv] add] have add: "LLL_Impl.basis_reduction_add_rows n upw i state = state'" and c_add: "c_add \ (2 * n + 2 * i + 7) * i" by auto from result_costD[OF basis_reduction_swap_cost swapc] have swap: "LLL_Impl.basis_reduction_swap m i state' = state''" and c_swap: "c_swap \ 8 * (m - Suc i) + 4" by auto have "c_add + c_swap + 5 \ 8 * m + 2 + (2 * n + 2 * i) * i" using c_add c_swap i by (auto simp: field_simps) also have "\ \ 8 * m + 2 + (2 * n + 2 * m) * m" by (intro add_left_mono mult_mono, insert i, auto) also have "\ = 2 + (8 + 2 * n + 2 * m) * m" by (simp add: field_simps) finally have body: "c_add + c_swap + 5 \ body_cost" unfolding body_cost_def . obtain num denom where alpha: "quotient_of \ = (num,denom)" by force note res' = LLL_Impl.basis_reduction_step_def[of \ n m upw i state, unfolded add swap Let_def alpha split] note d = res res' show ?g1 unfolding d by (auto split: if_splits simp: cost_simps Let_def alpha swapc) show ?g2 unfolding d nat_distrib using body by (auto split: if_splits simp: cost_simps alpha Let_def swapc) qed partial_function (tailrec) basis_reduction_main_cost where "basis_reduction_main_cost upw i state c = (if i < m then let ((upw',i',state'), c_step) = basis_reduction_step_cost upw i state in basis_reduction_main_cost upw' i' state' (c + c_step) else (state, c))" definition "num_loops = m + 2 * m * m * nat (ceiling (log base (real N)))" lemma basis_reduction_main_cost: assumes impl: "LLL_impl_inv state i (fs_state state)" and inv: "LLL_invariant upw i (fs_state state)" and state: "state = initial_state m fs_init" and i: "i = 0" shows "result (basis_reduction_main_cost upw i state c) = LLL_Impl.basis_reduction_main \ n m upw i state" (is ?g1) "cost (basis_reduction_main_cost upw i state c) \ c + body_cost * num_loops" (is ?g2) proof - have ?g1 and cost: "cost (basis_reduction_main_cost upw i state c) \ c + body_cost * LLL_measure i (fs_state state)" using assms(1-2) proof (atomize (full), induct "LLL_measure i (fs_state state)" arbitrary: upw i state c rule: less_induct) case (less i state upw c) note inv = less(3) note impl = less(2) obtain i' upw' state' c_step where step: "basis_reduction_step_cost upw i state = ((upw',i',state'),c_step)" (is "?step = _") by (cases ?step, auto) obtain state'' c_rec where rec: "basis_reduction_main_cost upw' i' state' (c + c_step) = (state'', c_rec)" (is "?rec = _") by (cases ?rec, auto) note step' = result_costD[OF basis_reduction_step_cost[OF impl inv] step] note d = basis_reduction_main_cost.simps[of upw] step split rec LLL_Impl.basis_reduction_main.simps[of _ _ _ upw] show ?case proof (cases "i < m") case i: True from step' i have step': "LLL_Impl.basis_reduction_step \ n m upw i state = (upw',i',state')" and c_step: "c_step \ body_cost" by auto note d = d step' from basis_reduction_step[OF impl inv step' i refl] have impl': "LLL_impl_inv state' i' (fs_state state')" and inv': "LLL_invariant upw' i' (fs_state state')" and meas: "LLL_measure i' (fs_state state') < LLL_measure i (fs_state state)" by auto from result_costD'[OF less(1)[OF meas impl' inv'] rec] have rec': "LLL_Impl.basis_reduction_main \ n m upw' i' state' = state''" and c_rec: "c_rec \ c + c_step + body_cost * LLL_measure i' (fs_state state')" by auto from c_step c_rec have "c_rec \ c + body_cost * Suc (LLL_measure i' (fs_state state'))" by auto also have "\ \ c + body_cost * LLL_measure i (fs_state state)" using meas by (intro plus_right_mono mult_left_mono) auto finally show ?thesis using i inv impl by (auto simp: cost_simps d rec') next case False thus ?thesis unfolding d by (auto simp: cost_simps) qed qed show ?g1 by fact note cost also have "body_cost * LLL_measure i (fs_state state) \ body_cost * num_loops" proof (rule mult_left_mono; linarith?) define l where "l = log base (real N)" define k where "k = 2 * m * m" obtain f mu ds where init: "initial_state m fs_init = (f,mu,ds)" by (cases "initial_state m fs_init", auto) from initial_state have fs: "fs_state (initial_state m fs_init) = fs_init" by auto have "LLL_measure i (fs_state state) \ nat (ceiling (m + k * l))" unfolding l_def k_def using LLL_measure_approx_fs_init[OF LLL_inv_initial_state \_gt m0] unfolding state fs i by linarith also have "\ \ num_loops" unfolding num_loops_def l_def[symmetric] k_def[symmetric] by (simp add: of_nat_ceiling times_right_mono) finally show "LLL_measure i (fs_state state) \ num_loops" . qed finally show ?g2 by auto qed context fixes fs :: "int vec iarray" begin fun sigma_array_cost where "sigma_array_cost dmus dmusi dmusj dll l = (if l = 0 then (dmusi !! l * dmusj !! l, 1) else let l1 = l - 1; dll1 = dmus !! l1 !! l1; (sig, cost_rec) = sigma_array_cost dmus dmusi dmusj dll1 l1; res = (dll * sig + dmusi !! l * dmusj !! l) div dll1; \ \4 arith. operations\ local_cost = (4 :: nat) in (res, local_cost + cost_rec))" declare sigma_array_cost.simps[simp del] lemma sigma_array_cost: "result (sigma_array_cost dmus dmusi dmusj dll l) = sigma_array dmus dmusi dmusj dll l" "cost (sigma_array_cost dmus dmusi dmusj dll l) \ 4 * l + 1" proof (atomize(full), induct l arbitrary: dll) case 0 show ?case unfolding sigma_array_cost.simps[of _ _ _ _ 0] sigma_array.simps[of _ _ _ _ 0] by (simp add: cost_simps) next case (Suc l) let ?sl = "Suc l" let ?dll = "dmus !! (Suc l - 1) !! (Suc l - 1)" show ?case unfolding sigma_array_cost.simps[of _ _ _ _ ?sl] sigma_array.simps[of _ _ _ _ ?sl] Let_def using Suc[of ?dll] by (auto split: prod.splits simp: cost_simps) qed function dmu_array_row_main_cost where "dmu_array_row_main_cost fi i dmus j = (if j \ i then (dmus, 0) else let sj = Suc j; dmus_i = dmus !! i; djj = dmus !! j !! j; (sigma, cost_sigma) = sigma_array_cost dmus dmus_i (dmus !! sj) djj j; dmu_ij = djj * (fi \ fs !! sj) - sigma; \ \2n + 2 arith. operations\ dmus' = iarray_update dmus i (iarray_append dmus_i dmu_ij); (res, cost_rec) = dmu_array_row_main_cost fi i dmus' sj; local_cost = 2 * n + 2 in (res, cost_rec + cost_sigma + local_cost))" by pat_completeness auto termination by (relation "measure (\ (fi,i,dmus,j). i - j)", auto) declare dmu_array_row_main_cost.simps[simp del] lemma dmu_array_row_main_cost: assumes "j \ i" shows "result (dmu_array_row_main_cost fi i dmus j) = dmu_array_row_main fs fi i dmus j" "cost (dmu_array_row_main_cost fi i dmus j) \ (\ jj \ {j ..< i}. 2 * n + 2 + 4 * jj + 1)" using assms proof (atomize(full), induct "i - j" arbitrary: j dmus) case (0 j dmus) hence j: "j = i" by auto thus ?case unfolding dmu_array_row_main_cost.simps[of _ _ _ j] dmu_array_row_main.simps[of _ _ _ _ j] by (simp add: cost_simps) next case (Suc l j dmus) from Suc(2) have id: "(i \ j) = False" "(j = i) = False" by auto let ?sl = "Suc l" let ?dll = "dmus !! (Suc l - 1) !! (Suc l - 1)" obtain sig c_sig where sig_c: "sigma_array_cost dmus (dmus !! i) (dmus !! Suc j) (dmus !! j !! j) j = (sig,c_sig)" by force from result_costD[OF sigma_array_cost sig_c] have sig: "sigma_array dmus (dmus !! i) (dmus !! Suc j) (dmus !! j !! j) j = sig" and c_sig: "c_sig \ 4 * j + 1" by auto obtain dmus' where dmus': "iarray_update dmus i (iarray_append (dmus !! i) (dmus !! j !! j * (fi \ fs !! Suc j) - sig)) = dmus'" by auto obtain res c_rec where rec_c: "dmu_array_row_main_cost fi i dmus' (Suc j) = (res, c_rec)" by force let ?c = "\ j. 2 * n + 2 + 4 * j + 1" from Suc(2-3) have "l = i - Suc j" "Suc j \ i" by auto from Suc(1)[OF this, of dmus', unfolded rec_c cost_simps] have rec: "dmu_array_row_main fs fi i dmus' (Suc j) = res" and c_rec: "c_rec \ (\jj = Suc j.. ?c j + (\jj = Suc j.. = (\jj = j.. (\jj = j.. fs !! 0 \ \2n arith. operations\; local_cost = 2 * n; (res, main_cost) = dmu_array_row_main_cost fi i (iarray_append dmus (IArray [sp])) 0 in (res, local_cost + main_cost))" lemma dmu_array_row_cost: "result (dmu_array_row_cost dmus i) = dmu_array_row fs dmus i" "cost (dmu_array_row_cost dmus i) \ 2 * n + (2 * n + 1 + 2 * i) * i" proof (atomize(full), goal_cases) case 1 let ?fi = "fs !! i" let ?arr = "iarray_append dmus (IArray [?fi \ fs !! 0])" obtain res c_main where res_c: "dmu_array_row_main_cost ?fi i ?arr 0 = (res, c_main)" by force from result_costD[OF dmu_array_row_main_cost res_c] have res: "dmu_array_row_main fs ?fi i ?arr 0 = res" and c_main: "c_main \ (\jj = 0.. 2 * n + (\jj = 0.. = 2 * n + (2 * n + 3) * i + 2 * (\jj < i. 2 * jj)" unfolding sum.distrib by (auto simp: sum_distrib_left field_simps intro: sum.cong) also have "(\jj < i. 2 * jj) = i * (i - 1)" by (induct i, force, rename_tac i, case_tac i, auto) finally have "2 * n + c_main \ 2 * n + (2 * n + 3 + 2 * (i - 1)) * i" by (simp add: field_simps) also have "\ = 2 * n + (2 * n + 1 + 2 * i) * i" by (cases i, auto simp: field_simps) finally have "2 * n + c_main \ 2 * n + (2 * n + 1 + 2 * i) * i" . thus ?case unfolding dmu_array_row_cost_def Let_def dmu_array_row_def res_c res split cost_simps by auto qed function dmu_array_cost where "dmu_array_cost dmus i = (if i \ m then (dmus,0) else let (dmus', cost_row) = dmu_array_row_cost dmus i; (res, cost_rec) = dmu_array_cost dmus' (Suc i) in (res, cost_row + cost_rec))" by pat_completeness auto termination by (relation "measure (\ (dmus, i). m - i)", auto) declare dmu_array_cost.simps[simp del] lemma dmu_array_cost: assumes "i \ m" shows "result (dmu_array_cost dmus i) = dmu_array fs m dmus i" "cost (dmu_array_cost dmus i) \ (\ ii \ {i ..< m}. 2 * n + (2 * n + 1 + 2 * ii) * ii)" using assms proof (atomize(full), induct "m - i" arbitrary: i dmus) case (0 i dmus) hence i: "i = m" by auto thus ?case unfolding dmu_array_cost.simps[of _ i] dmu_array.simps[of _ _ _ i] by (simp add: cost_simps) next case (Suc k i dmus) obtain dmus' c_row where row_c: "dmu_array_row_cost dmus i = (dmus',c_row)" by force from result_costD[OF dmu_array_row_cost row_c] have row: "dmu_array_row fs dmus i = dmus'" and c_row: "c_row \ 2 * n + (2 * n + 1 + 2 * i) * i" (is "_ \ ?c i") by auto from Suc have "k = m - Suc i" "Suc i \ m" and id: "(m \ i) = False" "(i = m) = False" by auto note IH = Suc(1)[OF this(1-2)] obtain res c_rec where rec_c: "dmu_array_cost dmus' (Suc i) = (res, c_rec)" by force from result_costD'[OF IH rec_c] have rec: "dmu_array fs m dmus' (Suc i) = res" and c_rec: "c_rec \ (\ii = Suc i.. ?c i + (\ii = Suc i.. = (\ii = i.._impl_cost :: "int vec list \ int iarray iarray cost" where "d\_impl_cost fs = dmu_array_cost (IArray fs) (IArray []) 0" lemma d\_impl_cost: "result (d\_impl_cost fs_init) = d\_impl fs_init" "cost (d\_impl_cost fs_init) \ m * (m * (m + n + 2) + 2 * n + 1)" proof (atomize(full), goal_cases) case 1 let ?fs = "IArray fs_init" let ?dmus = "IArray []" obtain res cost where res_c: "dmu_array_cost ?fs ?dmus 0 = (res, cost)" by force from result_costD[OF dmu_array_cost res_c] have res: "dmu_array ?fs m ?dmus 0 = res" and cost: "cost \ (\ii = 0..ii = 0..ii = 0..ii = 0.. \ 2 * n * m + (2 * n + 2) * (\ii = 0..ii = 0..ii = 0..ii = 0..ii = 0..ii = 0..ii = 0..ii = 0.. 2 * n * m + (n + 1) * (m * (m - 1)) + (2 * (m - 1) * (m - 1) * (m - 1) + 3 * (m - 1) * (m - 1) + (m - 1)) div 3" . also have "\ \ 2 * n * m + (n + 1) * (m * m) + (3 * m * m * m + 3 * m * m + 3 * m) div 3" by (intro add_mono div_le_mono mult_mono, auto) also have "\ = 2 * n * m + (n + 1) * (m * m) + (m * m * m + m * m + m)" by simp also have "\ = m * (m * (m + n + 2) + 2 * n + 1)" by (simp add: algebra_simps) finally show ?case unfolding d\_impl_cost_def d\_impl_def len res res_c cost_simps by simp qed definition "initial_gso_cost = m * (m * (m + n + 2) + 2 * n + 1)" definition "initial_state_cost fs = (let (dmus, cost) = d\_impl_cost fs; ds = IArray.of_fun (\ i. if i = 0 then 1 else let i1 = i - 1 in dmus !! i1 !! i1) (Suc m); dmus' = IArray.of_fun (\ i. let row_i = dmus !! i in IArray.of_fun (\ j. row_i !! j) i) m in ((([], fs), dmus', ds), cost) :: LLL_dmu_d_state cost)" definition basis_reduction_cost :: "_ \ LLL_dmu_d_state cost" where "basis_reduction_cost fs = ( case initial_state_cost fs of (state1, c1) \ case basis_reduction_main_cost True 0 state1 0 of (state2, c2) \ (state2, c1 + c2))" definition reduce_basis_cost :: "_ \ int vec list cost" where "reduce_basis_cost fs = (case fs of Nil \ (fs, 0) | Cons f _ \ case basis_reduction_cost fs of (state,c) \ (fs_state state, c))" lemma initial_state_cost: "result (initial_state_cost fs_init) = initial_state m fs_init" (is ?g1) "cost (initial_state_cost fs_init) \ initial_gso_cost" (is ?g2) proof - obtain st c where dmu: "d\_impl_cost fs_init = (st,c)" by force from d\_impl_cost[unfolded dmu cost_simps] have dmu': "d\_impl fs_init = st" and c: "c \ initial_gso_cost" unfolding initial_gso_cost_def by auto show ?g1 ?g2 using c unfolding initial_state_cost_def dmu dmu' split cost_simps initial_state_def Let_def by auto qed lemma basis_reduction_cost: "result (basis_reduction_cost fs_init) = basis_reduction \ n fs_init" (is ?g1) "cost (basis_reduction_cost fs_init) \ initial_gso_cost + body_cost * num_loops" (is ?g2) proof - obtain state1 c1 where init: "initial_state_cost fs_init = (state1, c1)" (is "?init = _") by (cases ?init, auto) obtain state2 c2 where main: "basis_reduction_main_cost True 0 state1 0 = (state2, c2)" (is "?main = _") by (cases ?main, auto) have res: "basis_reduction_cost fs_init = (state2, c1 + c2)" unfolding basis_reduction_cost_def init main split by simp from result_costD[OF initial_state_cost init] have c1: "c1 \ initial_gso_cost" and init: "initial_state m fs_init = state1" by auto note inv = LLL_inv_initial_state(1) note impl = initial_state have fs: "fs_state (initial_state m fs_init) = fs_init" by fact from basis_reduction_main_cost[of "initial_state m fs_init" _ _ 0, unfolded fs, OF impl(1) inv, unfolded init main cost_simps] have main: "LLL_Impl.basis_reduction_main \ n m True 0 state1 = state2" and c2: "c2 \ body_cost * num_loops" by auto have res': "basis_reduction \ n fs_init = state2" unfolding basis_reduction_def len init main Let_def .. show ?g1 unfolding res res' cost_simps .. show ?g2 unfolding res cost_simps using c1 c2 by auto qed text \The lemma for the LLL algorithm with explicit cost annotations @{const reduce_basis_cost} shows that the termination measure indeed gives rise to an explicit cost bound. Moreover, the computed result is the same as in the non-cost counting @{const reduce_basis}.\ lemma reduce_basis_cost: "result (reduce_basis_cost fs_init) = LLL_Impl.reduce_basis \ fs_init" (is ?g1) "cost (reduce_basis_cost fs_init) \ initial_gso_cost + body_cost * num_loops" (is ?g2) proof (atomize(full), goal_cases) case 1 note d = reduce_basis_cost_def LLL_Impl.reduce_basis_def show ?case proof (cases fs_init) case Nil show ?thesis unfolding d unfolding Nil by (auto simp: cost_simps) next case (Cons f) obtain state c where b: "basis_reduction_cost fs_init = (state,c)" (is "?b = _") by (cases ?b, auto) from result_costD[OF basis_reduction_cost b] have bb: "basis_reduction \ n fs_init = state" and c: "c \ initial_gso_cost + body_cost * num_loops" by auto from fs_init[unfolded Cons] have dim: "dim_vec f = n" by auto show ?thesis unfolding d b split unfolding Cons list.simps unfolding Cons[symmetric] dim bb using c by (auto simp: cost_simps) qed qed lemma mn: "m \ n" unfolding len[symmetric] using lin_dep length_map unfolding gs.lin_indpt_list_def by (metis distinct_card gs.dim_is_n gs.fin_dim gs.li_le_dim(2)) text \Theorem with expanded costs: $O(n\cdot m^3 \cdot \log (\mathit{maxnorm}\ F))$ arithmetic operations\ lemma reduce_basis_cost_expanded: assumes "Lg \ nat \log (of_rat (4 * \ / (4 + \))) N\" shows "cost (reduce_basis_cost fs_init) \ 4 * Lg * m * m * m * n + 4 * Lg * m * m * m * m + 16 * Lg * m * m * m + 4 * Lg * m * m + 3 * m * m * m + 3 * m * m * n + 10 * m * m + 2 * n * m + 3 * m" (is "?cost \ ?exp Lg") proof - define Log where "Log = nat \log (of_rat (4 * \ / (4 + \))) N\" have Lg: "Log \ Lg" using assms unfolding Log_def . have "?cost \ ?exp Log" unfolding Log_def using reduce_basis_cost(2)[unfolded num_loops_def body_cost_def initial_gso_cost_def base_def] by (auto simp: algebra_simps) also have "\ \ ?exp Lg" by (intro add_mono mult_mono Lg, auto) finally show ?thesis . qed lemma reduce_basis_cost_0: assumes "m = 0" shows "cost (reduce_basis_cost fs_init) = 0" proof - from len assms have fs_init: "fs_init = []" by auto thus ?thesis unfolding reduce_basis_cost_def by (simp add: cost_simps) qed lemma reduce_basis_cost_N: assumes "Lg \ nat \log (of_rat (4 * \ / (4 + \))) N\" and 0: "Lg > 0" shows "cost (reduce_basis_cost fs_init) \ 49 * m ^ 3 * n * Lg" proof (cases "m > 0") case True with mn 0 have 0: "0 < Lg" "0 < m" "0 < n" by auto note reduce_basis_cost_expanded[OF assms(1)] also have "4 * Lg * m * m * m * n = 4 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "4 * Lg * m * m * m * m \ 4 * m ^ 3 * n * Lg" using 0 mn by (auto simp add: power3_eq_cube) also have "16 * Lg * m * m * m \ 16 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "4 * Lg * m * m \ 4 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "3 * m * m * m \ 3 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "3 * m * m * n \ 3 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "10 * m * m \ 10 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "2 * n * m \ 2 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) also have "3 * m \ 3 * m ^ 3 * n * Lg" using 0 by (auto simp add: power3_eq_cube) finally show ?thesis by (auto simp add: algebra_simps) next case False with reduce_basis_cost_0 show ?thesis by simp qed lemma reduce_basis_cost_M: assumes "Lg \ nat \log (of_rat (4 * \ / (4 + \))) (M * n)\" and 0: "Lg > 0" shows "cost (reduce_basis_cost fs_init) \ 98 * m ^ 3 * n * Lg" proof (cases "m > 0") case True let ?prod = "nat M * nat M * n" let ?p = "nat M * nat M * n * n" let ?lg = "real_of_int (M * n)" from 0 True have m0: "m \ 0" by simp - from LLL_inv_N_pos[OF LLL_inv_initial_state g_bound_fs_init m0] have N0: "N > 0" . + from LLL_inv_N_pos[OF LLL_inv_imp_w[OF LLL_inv_initial_state] g_bound_fs_init m0] have N0: "N > 0" . from N_le_MMn[OF m0] have N_prod: "N \ ?prod" by auto from N0 N_prod have M0: "M > 0" by (cases "M \ 0", auto) from N0 N_prod have prod0: "0 < ?prod" by linarith from prod0 have n0: "n > 0" by auto from n0 prod0 M0 have prod_p: "?prod \ ?p" by auto with N_prod prod0 have N_p: "N \ ?p" and p0: "0 < ?p" by linarith+ let ?base = "real_of_rat (4 * \ / (4 + \))" have base: "1 < ?base" using \_gt by auto have Lg: "nat \log ?base N\ \ nat \log ?base ?p\" by (intro nat_mono ceiling_mono log_mono, subst log_le_cancel_iff[OF base], insert M0 N_p N0 p0 n0, auto simp flip: of_int_mult of_nat_mult) also have "log ?base ?p = log ?base (?lg^2)" using M0 by (simp add: power2_eq_square ac_simps) also have "\ = 2 * log ?base ?lg" by (subst log_nat_power, insert M0 n0, auto) finally have "nat \log ?base N\ \ nat \2 * log ?base ?lg\" . also have "\ \ 2 * Lg" using assms by linarith finally have Log: "nat \log ?base N\ \ 2 * Lg" . from 0 have "0 < 2 * Lg" by simp from reduce_basis_cost_N[OF Log this] show ?thesis by simp next case False with reduce_basis_cost_0 show ?thesis by simp qed end (* fixing arith_cost and assume \ > 4/3 *) end (* LLL locale *) end (* theory *) diff --git a/thys/LLL_Basis_Reduction/LLL_Impl.thy b/thys/LLL_Basis_Reduction/LLL_Impl.thy --- a/thys/LLL_Basis_Reduction/LLL_Impl.thy +++ b/thys/LLL_Basis_Reduction/LLL_Impl.thy @@ -1,1143 +1,1153 @@ (* Authors: René Thiemann License: BSD *) subsection \Integer LLL Implementation which Stores Multiples of the $\mu$-Values\ text \In this part we aim to update the integer values $d\,(j+1) * \mu_{i,j}$ as well as the Gramian determinants $d\,i$. \ theory LLL_Impl imports LLL List_Representation Gram_Schmidt_Int begin subsubsection \Updates of the integer values for Swap, Add, etc.\ text \We provide equations how to implement the LLL-algorithm by storing the integer values $d\, (j+1) * \mu_{i,j}$ and all $d\ i$ in addition to the vectors in $f$. Moreover, we show how to check condition like the one on norms via the integer values.\ definition round_num_denom :: "int \ int \ int" where "round_num_denom n d = ((2 * n + d) div (2 * d))" lemma round_num_denom: "round_num_denom num denom = round (of_int num / rat_of_int denom)" proof (cases "denom = 0") case False have "denom \ 0 \ ?thesis" unfolding round_def round_num_denom_def unfolding floor_divide_of_int_eq[where ?'a = rat, symmetric] by (rule arg_cong[of _ _ floor], simp add: add_divide_distrib) with False show ?thesis by auto next case True show ?thesis unfolding True round_num_denom_def by auto qed context fs_int_indpt begin lemma round_num_denom_d\_d: assumes j: "j \ i" and i: "i < m" shows "round_num_denom (d\ i j) (d fs (Suc j)) = round (gs.\ i j)" proof - from j i have sj: "Suc j \ m" by auto show ?thesis unfolding round_num_denom by (rule arg_cong[of _ _ round], subst d\[OF _ i], insert j i fs_int_d_pos[OF sj], auto) qed lemma d_sq_norm_comparison: assumes quot: "quotient_of \ = (num,denom)" and i: "i < m" and i0: "i \ 0" shows "(d fs i * d fs i * denom \ num * d fs (i - 1) * d fs (Suc i)) = (sq_norm (gs.gso (i - 1)) \ \ * sq_norm (gs.gso i))" proof - let ?r = "rat_of_int" let ?x = "sq_norm (gs.gso (i - 1))" let ?y = "\ * sq_norm (gs.gso i)" from i have le: "i - 1 \ m" " i \ m" "Suc i \ m" by auto note pos = fs_int_d_pos[OF le(1)] fs_int_d_pos[OF le(2)] quotient_of_denom_pos[OF quot] have "(d fs i * d fs i * denom \ num * d fs (i - 1) * d fs (Suc i)) = (?r (d fs i * d fs i * denom) \ ?r (num * d fs (i - 1) * d fs (Suc i)))" (is "?cond = _") by presburger also have "\ = (?r (d fs i) * ?r (d fs i) * ?r denom \ ?r num * ?r (d fs (i - 1)) * ?r (d fs (Suc i)))" by simp also have "\ = (?r (d fs i) * ?r (d fs i) \ \ * ?r (d fs (i - 1)) * ?r (d fs (Suc i)))" using pos unfolding quotient_of_div[OF quot] by (auto simp: field_simps) also have "\ = (?r (d fs i) / ?r (d fs (i - 1)) \ \ * (?r (d fs (Suc i)) / ?r (d fs i)))" using pos by (auto simp: field_simps) also have "?r (d fs i) / ?r (d fs (i - 1)) = ?x" using fs_int_d_Suc[of "i - 1"] pos i i0 by (auto simp: field_simps) also have "\ * (?r (d fs (Suc i)) / ?r (d fs i)) = ?y" using fs_int_d_Suc[OF i] pos i i0 by (auto simp: field_simps) finally show "?cond = (?x \ ?y)" . qed end context LLL begin -lemma d_d\_add_row: assumes Linv: "LLL_invariant True i fs" +lemma d_d\_add_row: assumes Linv: "LLL_invariant_weak fs" and i: "i < m" and j: "j < i" and fs': "fs' = fs[ i := fs ! i - c \\<^sub>v fs ! j]" shows (* d-updates: none *) "\ ii. ii \ m \ d fs' ii = d fs ii" (* d\-updates: *) "\ i' j'. i' < m \ j' < i' \ d\ fs' i' j' = ( if i' = i \ j' < j then d\ fs i' j' - c * d\ fs j j' else if i' = i \ j' = j then d\ fs i' j' - c * d fs (Suc j) else d\ fs i' j')" (is "\ i' j'. _ \ _ \ _ = ?new_mu i' j'") proof - - interpret fs: fs_int' n m fs_init \ True i fs + interpret fs: fs_int' n m fs_init fs by standard (use Linv in auto) note add = basis_reduction_add_row_main[OF Linv i j fs'] - interpret fs': fs_int' n m fs_init \ True i fs' + interpret fs': fs_int' n m fs_init fs' by standard (use add in auto) show d: "\ ii. ii \ m \ d fs' ii = d fs ii" by fact fix i' j' assume i': "i' < m" and j': "j' < i'" hence j'm: "j' < m" and j'': "j' \ i'" by auto - note updates = add(5)[OF i' j'm] + note updates = add(7)[OF i' j'm] show "d\ fs' i' j' = ?new_mu i' j'" proof (cases "i' = i") case False thus ?thesis using d i' j' unfolding d\_def updates by auto next case True have id': "d fs' (Suc j') = d fs (Suc j')" by (rule d, insert i' j', auto) note fs'.d\[] have *: "rat_of_int (d\ fs' i' j') = rat_of_int (d fs' (Suc j')) * fs'.gs.\ i' j'" unfolding d\_def d_def apply(rule fs'.d\[unfolded fs'.d\_def fs'.d_def]) - using j' i' LLL_invD[OF add(1)] by (auto) + using j' i' LLL_inv_wD[OF add(1)] by (auto) have **: "rat_of_int (d\ fs i' j') = rat_of_int (d fs (Suc j')) * fs.gs.\ i' j'" unfolding d\_def d_def apply(rule fs.d\[unfolded fs.d\_def fs.d_def]) - using j' i' LLL_invD[OF Linv] by (auto) + using j' i' LLL_inv_wD[OF Linv] by (auto) have ***: "rat_of_int (d\ fs j j') = rat_of_int (d fs (Suc j')) * fs.gs.\ j j'" if "j' < j" unfolding d\_def d_def apply(rule fs.d\[unfolded fs.d\_def fs.d_def]) - using that j i LLL_invD[OF Linv] by (auto) + using that j i LLL_inv_wD[OF Linv] by (auto) show ?thesis apply(intro int_via_rat_eqI) apply(unfold if_distrib[of rat_of_int] of_int_diff of_int_mult ** * updates id' ring_distribs) apply(insert True i' j' i j) by(auto simp: fs.gs.\.simps algebra_simps ***) qed qed end context LLL_with_assms begin -lemma d_d\_swap: assumes inv: "LLL_invariant False k fs" +lemma d_d\_swap: assumes invw: "LLL_invariant_weak fs" + and small: "LLL_invariant False k fs \ abs (\ fs k (k - 1)) \ 1/2" and k: "k < m" and k0: "k \ 0" and norm_ineq: "sq_norm (gso fs (k - 1)) > \ * sq_norm (gso fs k)" and fs'_def: "fs' = fs[k := fs ! (k - 1), k - 1 := fs ! k]" shows (* d-updates *) "\ i. i \ m \ d fs' i = ( if i = k then (d fs (Suc k) * d fs (k - 1) + d\ fs k (k - 1) * d\ fs k (k - 1)) div d fs k else d fs i)" and (* d\-updates *) "\ i j. i < m \ j < i \ d\ fs' i j = ( if i = k - 1 then d\ fs k j else if i = k \ j \ k - 1 then d\ fs (k - 1) j else if i > k \ j = k then (d fs (Suc k) * d\ fs i (k - 1) - d\ fs k (k - 1) * d\ fs i j) div d fs k else if i > k \ j = k - 1 then (d\ fs k (k - 1) * d\ fs i j + d\ fs i k * d fs (k - 1)) div d fs k else d\ fs i j)" (is "\ i j. _ \ _ \ _ = ?new_mu i j") proof - - note swap = basis_reduction_swap_main[OF inv k k0 norm_ineq fs'_def] + note swap = basis_reduction_swap_main[OF invw small k k0 norm_ineq fs'_def] + note invw2 = swap(1) + note swap = swap(1,3-) from k k0 have kk: "k - 1 < k" and le_m: "k - 1 \ m" "k \ m" "Suc k \ m" by auto - from LLL_invD[OF inv] have len: "length fs = m" by auto - interpret fs: fs_int' n m fs_init \ False k fs - by standard (use inv in auto) - interpret fs': fs_int' n m fs_init \ False "k - 1" fs' - by standard (use swap(1) in auto) + from LLL_inv_wD[OF invw] have len: "length fs = m" by auto + interpret fs: fs_int' n m fs_init fs + by standard (use invw in auto) + interpret fs': fs_int' n m fs_init fs' + by standard (use invw2 in auto) let ?r = rat_of_int let ?n = "\ i. sq_norm (gso fs i)" let ?n' = "\ i. sq_norm (gso fs' i)" let ?dn = "\ i. ?r (d fs i * d fs i) * ?n i" let ?dn' = "\ i. ?r (d fs' i * d fs' i) * ?n' i" let ?dmu = "\ i j. ?r (d fs (Suc j)) * \ fs i j" let ?dmu' = "\ i j. ?r (d fs' (Suc j)) * \ fs' i j" note dmu = fs.d\ note dmu' = fs'.d\ - note inv' = LLL_invD[OF inv] + note inv' = LLL_inv_wD[OF invw] have nim1: "?n k + square_rat (\ fs k (k - 1)) * ?n (k - 1) = ?n' (k - 1)" by (subst swap(4), insert k, auto) have ni: "?n k * (?n (k - 1) / ?n' (k - 1)) = ?n' k" by (subst swap(4)[of k], insert k k0, auto) have mu': "\ fs k (k - 1) * (?n (k - 1) / ?n' (k - 1)) = \ fs' k (k - 1)" by (subst swap(5), insert k k0, auto) have fi: "fs ! (k - 1) = fs' ! k" "fs ! k = fs' ! (k - 1)" unfolding fs'_def using inv'(6) k k0 by auto let ?d'i = "(d fs (Suc k) * d fs (k - 1) + d\ fs k (k - 1) * d\ fs k (k - 1)) div (d fs k)" have rat': "i < m \ j < i \ ?r (d\ fs' i j) = ?dmu' i j" for i j - using dmu'[of j i] LLL_invD[OF swap(1)] unfolding d\_def fs'.d\_def d_def fs'.d_def by auto + using dmu'[of j i] LLL_inv_wD[OF invw2] unfolding d\_def fs'.d\_def d_def fs'.d_def by auto have rat: "i < m \ j < i \ ?r (d\ fs i j) = ?dmu i j" for i j - using dmu[of j i] LLL_invD[OF inv] unfolding d\_def fs.d\_def d_def fs.d_def by auto + using dmu[of j i] LLL_inv_wD[OF invw] unfolding d\_def fs.d\_def d_def fs.d_def by auto from k k0 have sim1: "Suc (k - 1) = k" and km1: "k - 1 < m" by auto - from LLL_d_Suc[OF inv km1, unfolded sim1] + from LLL_d_Suc[OF invw km1, unfolded sim1] have dn_km1: "?dn (k - 1) = ?r (d fs k) * ?r (d fs (k - 1))" by simp - note pos = Gramian_determinant[OF inv le_refl] + note pos = Gramian_determinant[OF invw le_refl] from pos(2) have "?r (gs.Gramian_determinant fs m) \ 0" by auto from this[unfolded pos(1)] have nzero: "i < m \ ?n i \ 0" for i by auto - note pos = Gramian_determinant[OF swap(1) le_refl] + note pos = Gramian_determinant[OF invw2 le_refl] from pos(2) have "?r (gs.Gramian_determinant fs' m) \ 0" by auto from this[unfolded pos(1)] have nzero': "i < m \ ?n' i \ 0" for i by auto - have dzero: "i \ m \ d fs i \ 0" for i using LLL_d_pos[OF inv, of i] by auto - have dzero': "i \ m \ d fs' i \ 0" for i using LLL_d_pos[OF swap(1), of i] by auto + have dzero: "i \ m \ d fs i \ 0" for i using LLL_d_pos[OF invw, of i] by auto + have dzero': "i \ m \ d fs' i \ 0" for i using LLL_d_pos[OF invw2, of i] by auto { define start where "start = ?dmu' k (k - 1)" have "start = (?n' (k - 1) / ?n (k - 1) * ?r (d fs k)) * \ fs' k (k - 1)" using start_def swap(6)[of k] k k0 by simp also have "\ fs' k (k - 1) = \ fs k (k - 1) * (?n (k - 1) / ?n' (k - 1))" using mu' by simp also have "(?n' (k - 1) / ?n (k - 1) * ?r (d fs k)) * \ = ?r (d fs k) * \ fs k (k - 1)" using nzero[OF km1] nzero'[OF km1] by simp also have "\ = ?dmu k (k - 1)" using k0 by simp finally have "?dmu' k (k - 1) = ?dmu k (k - 1)" unfolding start_def . } note dmu_i_im1 = this { (* d updates *) fix j assume j: "j \ m" define start where "start = d fs' j" { assume jj: "j \ k" have "?r start = ?r (d fs' j)" unfolding start_def .. also have "?r (d fs' j) = ?r (d fs j)" by (subst swap(6), insert j jj, auto) finally have "start = d fs j" by simp } note d_j = this { assume jj: "j = k" have "?r start = ?r (d fs' k)" unfolding start_def unfolding jj by simp also have "\ = ?n' (k - 1) / ?n (k - 1) * ?r (d fs k)" by (subst swap(6), insert k, auto) also have "?n' (k - 1) = (?r (d fs k) / ?r (d fs k)) * (?r (d fs k) / ?r (d fs k)) * (?n k + \ fs k (k - 1) * \ fs k (k - 1) * ?n (k - 1))" by (subst swap(4)[OF km1], insert dzero[of k], insert k, simp) also have "?n (k - 1) = ?r (d fs k) / ?r (d fs (k - 1))" - unfolding LLL_d_Suc[OF inv km1, unfolded sim1] using dzero[of "k - 1"] k k0 by simp + unfolding LLL_d_Suc[OF invw km1, unfolded sim1] using dzero[of "k - 1"] k k0 by simp finally have "?r start = ((?r (d fs k) * ?n k) * ?r (d fs (k - 1)) + ?dmu k (k - 1) * ?dmu k (k - 1)) / (?r (d fs k))" using k k0 dzero[of k] dzero[of "k - 1"] by (simp add: ring_distribs) also have "?r (d fs k) * ?n k = ?r (d fs (Suc k))" - unfolding LLL_d_Suc[OF inv k] by simp + unfolding LLL_d_Suc[OF invw k] by simp also have "?dmu k (k - 1) = ?r (d\ fs k (k - 1))" by (subst rat, insert k k0, auto) finally have "?r start = (?r (d fs (Suc k) * d fs (k - 1) + d\ fs k (k - 1) * d\ fs k (k - 1))) / (?r (d fs k))" by simp from division_to_div[OF this] have "start = ?d'i" . } note d_i = this from d_j d_i show "d fs' j = (if j = k then ?d'i else d fs j)" unfolding start_def by auto } have "length fs' = m" using fs'_def inv'(6) by auto { fix i j assume i: "i < m" and j: "j < i" from j i have sj: "Suc j \ m" by auto note swaps = swap(5)[OF i j] swap(6)[OF sj] show "d\ fs' i j = ?new_mu i j" proof (cases "i < k - 1") case small: True hence id: "?new_mu i j = d\ fs i j" by auto show ?thesis using swaps small i j k k0 by (auto simp: d\_def) next case False from j i have sj: "Suc j \ m" by auto let ?start = "d\ fs' i j" define start where "start = ?start" note rat'[OF i j] note rat_i_j = rat[OF i j] from False consider (i_k) "i = k" "j = k - 1" | (i_small) "i = k" "j \ k - 1" | (i_km1) "i = k - 1" | (i_large) "i > k" by linarith thus ?thesis proof cases case *: i_small show ?thesis unfolding swaps d\_def using * i k k0 by auto next case *: i_k show ?thesis using dmu_i_im1 rat_i_j * k0 by (auto simp: d\_def) next case *: i_km1 show ?thesis unfolding swaps d\_def using * i j k k0 by auto next case *: i_large consider (jj) "j \ k - 1" "j \ k" | (ji) "j = k" | (jim1) "j = k - 1" by linarith thus ?thesis proof cases case jj show ?thesis unfolding swaps d\_def using * i j jj k k0 by auto next case ji have "?r start = ?dmu' i j" unfolding start_def by fact also have "?r (d fs' (Suc j)) = ?r (d fs (Suc k))" unfolding swaps unfolding ji by simp also have "\ fs' i j = \ fs i (k - 1) - \ fs k (k - 1) * \ fs i k" unfolding swaps unfolding ji using k0 * by auto also have "?r (d fs (Suc k)) * \ = ?r (d fs (Suc k)) * ?r (d fs k) / ?r (d fs k) * \" using dzero[of k] k by auto also have "\ = (?r (d fs (Suc k)) * ?dmu i (k - 1) - ?dmu k (k - 1) * ?dmu i k) / ?r (d fs k)" using k0 by (simp add: field_simps) also have "\ = (?r (d fs (Suc k)) * ?r (d\ fs i (k - 1)) - ?r (d\ fs k (k - 1)) * ?r (d\ fs i k)) / ?r (d fs k)" by (subst (1 2 3) rat, insert k k0 i *, auto) also have "\ = ?r (d fs (Suc k) * d\ fs i (k - 1) - d\ fs k (k - 1) * d\ fs i k) / ?r (d fs k)" (is "_ = of_int ?x / _") by simp finally have "?r start = ?r ?x / ?r (d fs k)" . from division_to_div[OF this] have id: "?start = (d fs (Suc k) * d\ fs i (k - 1) - d\ fs k (k - 1) * d\ fs i j) div d fs k" unfolding start_def ji . show ?thesis unfolding id using * ji by simp next case jim1 hence id'': "(j = k - 1) = True" "(j = k) = False" using k0 by auto have "?r (start) = ?dmu' i j" unfolding start_def by fact also have "\ fs' i j = \ fs i (k - 1) * \ fs' k (k - 1) + \ fs i k * ?n k / ?n' (k - 1)" (is "_ = ?x1 + ?x2") unfolding swaps unfolding jim1 using k0 * by auto also have "?r (d fs' (Suc j)) * (?x1 + ?x2) = ?r (d fs' (Suc j)) * ?x1 + ?r (d fs' (Suc j)) * ?x2" by (simp add: ring_distribs) also have "?r (d fs' (Suc j)) * ?x1 = ?dmu' k (k - 1) * (?r (d fs k) * \ fs i (k - 1)) / ?r (d fs k)" unfolding jim1 using k0 dzero[of k] k by simp also have "?dmu' k (k - 1) = ?dmu k (k - 1)" by fact also have "?r (d fs k) * \ fs i (k - 1) = ?dmu i (k - 1)" using k0 by simp also have "?r (d fs' (Suc j)) = ?n' (k - 1) * ?r (d fs k) / ?n (k - 1)" unfolding swaps unfolding jim1 using k k0 by simp also have "\ * ?x2 = (?n k * ?r (d fs k)) / ?n (k - 1) * \ fs i k" using k k0 nzero'[of "k - 1"] by simp - also have "?n k * ?r (d fs k) = ?r (d fs (Suc k))" unfolding LLL_d_Suc[OF inv k] .. + also have "?n k * ?r (d fs k) = ?r (d fs (Suc k))" unfolding LLL_d_Suc[OF invw k] .. also have "?r (d fs (Suc k)) / ?n (k - 1) * \ fs i k = ?dmu i k / ?n (k - 1)" by simp also have "\ = ?dmu i k * ?r (d fs (k - 1) * d fs (k - 1)) / ?dn (k - 1)" using dzero[of "k - 1"] k by simp finally have "?r start = (?dmu k (k - 1) * ?dmu i j * ?dn (k - 1) + ?dmu i k * (?r (d fs (k - 1) * d fs (k - 1) * d fs k))) / (?r (d fs k) * ?dn (k - 1))" unfolding add_divide_distrib of_int_mult jim1 using dzero[of "k - 1"] nzero[of "k - 1"] k dzero[of k] by auto also have "\ = (?r (d\ fs k (k - 1)) * ?r (d\ fs i j) * (?r (d fs k) * ?r (d fs (k - 1))) + ?r (d\ fs i k) * (?r (d fs (k - 1) * d fs (k - 1) * d fs k))) / (?r (d fs k) * (?r (d fs k) * ?r (d fs (k - 1))))" unfolding dn_km1 by (subst (1 2 3) rat, insert k k0 i * j, auto) also have "\ = (?r (d\ fs k (k - 1)) * ?r (d\ fs i j) + ?r (d\ fs i k) * ?r (d fs (k - 1))) / ?r (d fs k)" unfolding of_int_mult using dzero[of k] dzero[of "k - 1"] k k0 by (auto simp: field_simps) also have "\ = ?r (d\ fs k (k - 1) * d\ fs i j + d\ fs i k * d fs (k - 1)) / ?r (d fs k)" (is "_ = of_int ?x / _" ) by simp finally have "?r start = ?r ?x / ?r (d fs k)" . from division_to_div[OF this] have id: "?start = (d\ fs k (k - 1) * d\ fs i j + d\ fs i k * d fs (k - 1)) div (d fs k)" unfolding start_def . show ?thesis unfolding id using * jim1 k0 by auto qed qed qed } qed end subsubsection \Implementation of LLL via Integer Operations and Arrays\ hide_fact (open) Word.inc_i type_synonym LLL_dmu_d_state = "int vec list_repr \ int iarray iarray \ int iarray" fun fi_state :: "LLL_dmu_d_state \ int vec" where "fi_state (f,mu,d) = get_nth_i f" fun fim1_state :: "LLL_dmu_d_state \ int vec" where "fim1_state (f,mu,d) = get_nth_im1 f" fun d_state :: "LLL_dmu_d_state \ nat \ int" where "d_state (f,mu,d) i = d !! i" fun fs_state :: "LLL_dmu_d_state \ int vec list" where "fs_state (f,mu,d) = of_list_repr f" fun upd_fi_mu_state :: "LLL_dmu_d_state \ nat \ int vec \ int iarray \ LLL_dmu_d_state" where "upd_fi_mu_state (f,mu,d) i fi mu_i = (update_i f fi, iarray_update mu i mu_i,d)" fun small_fs_state :: "LLL_dmu_d_state \ int vec list" where "small_fs_state (f,_) = fst f" fun dmu_ij_state :: "LLL_dmu_d_state \ nat \ nat \ int" where "dmu_ij_state (f,mu,_) i j = mu !! i !! j" fun inc_state :: "LLL_dmu_d_state \ LLL_dmu_d_state" where "inc_state (f,mu,d) = (inc_i f, mu, d)" fun basis_reduction_add_rows_loop where "basis_reduction_add_rows_loop n state i j [] = state" | "basis_reduction_add_rows_loop n state i sj (fj # fjs) = ( let fi = fi_state state; dsj = d_state state sj; j = sj - 1; c = round_num_denom (dmu_ij_state state i j) dsj; state' = (if c = 0 then state else upd_fi_mu_state state i (vec n (\ i. fi $ i - c * fj $ i)) (IArray.of_fun (\ jj. let mu = dmu_ij_state state i jj in if jj < j then mu - c * dmu_ij_state state j jj else if jj = j then mu - dsj * c else mu) i)) in basis_reduction_add_rows_loop n state' i j fjs)" text \More efficient code which breaks abstraction of state.\ lemma basis_reduction_add_rows_loop_code: "basis_reduction_add_rows_loop n state i sj (fj # fjs) = ( case state of ((f1,f2),mus,ds) \ let fi = hd f2; j = sj - 1; dsj = ds !! sj; mui = mus !! i; c = round_num_denom (mui !! j) dsj in (if c = 0 then basis_reduction_add_rows_loop n state i j fjs else let muj = mus !! j in basis_reduction_add_rows_loop n ((f1, vec n (\ i. fi $ i - c * fj $ i) # tl f2), iarray_update mus i (IArray.of_fun (\ jj. let mu = mui !! jj in if jj < j then mu - c * muj !! jj else if jj = j then mu - dsj * c else mu) i), ds) i j fjs))" proof - obtain f1 f2 mus ds where state: "state = ((f1,f2),mus, ds)" by (cases state, auto) show ?thesis unfolding basis_reduction_add_rows_loop.simps Let_def state split dmu_ij_state.simps fi_state.simps get_nth_i_def update_i_def upd_fi_mu_state.simps d_state.simps by simp qed lemmas basis_reduction_add_rows_loop_code_equations = basis_reduction_add_rows_loop.simps(1) basis_reduction_add_rows_loop_code declare basis_reduction_add_rows_loop_code_equations[code] definition basis_reduction_add_rows where "basis_reduction_add_rows n upw i state = (if upw then basis_reduction_add_rows_loop n state i i (small_fs_state state) else state)" context fixes \ :: rat and n m :: nat and fs_init :: "int vec list" begin definition swap_mu :: "int iarray iarray \ nat \ int \ int \ int \ int \ int iarray iarray" where "swap_mu dmu i dmu_i_im1 dim1 di dsi = (let im1 = i - 1 in IArray.of_fun (\ ii. if ii < im1 then dmu !! ii else if ii > i then let dmu_ii = dmu !! ii in IArray.of_fun (\ j. let dmu_ii_j = dmu_ii !! j in if j = i then (dsi * dmu_ii !! im1 - dmu_i_im1 * dmu_ii_j) div di else if j = im1 then (dmu_i_im1 * dmu_ii_j + dmu_ii !! i * dim1) div di else dmu_ii_j) ii else if ii = i then let mu_im1 = dmu !! im1 in IArray.of_fun (\ j. if j = im1 then dmu_i_im1 else mu_im1 !! j) ii else IArray.of_fun (\ j. dmu !! i !! j) ii) \ \ii = i - 1\ m)" definition basis_reduction_swap where "basis_reduction_swap i state = (let di = d_state state i; dsi = d_state state (Suc i); dim1 = d_state state (i - 1); fi = fi_state state; fim1 = fim1_state state; dmu_i_im1 = dmu_ij_state state i (i - 1); fi' = fim1; fim1' = fi in (case state of (f,dmus,djs) \ (False, i - 1, (dec_i (update_im1 (update_i f fi') fim1'), swap_mu dmus i dmu_i_im1 dim1 di dsi, iarray_update djs i ((dsi * dim1 + dmu_i_im1 * dmu_i_im1) div di)))))" text \More efficient code which breaks abstraction of state.\ lemma basis_reduction_swap_code[code]: "basis_reduction_swap i ((f1,f2), dmus, ds) = (let di = ds !! i; dsi = ds !! (Suc i); im1 = i - 1; dim1 = ds !! im1; fi = hd f2; fim1 = hd f1; dmu_i_im1 = dmus !! i !! im1; fi' = fim1; fim1' = fi in (False, im1, ((tl f1,fim1' # fi' # tl f2), swap_mu dmus i dmu_i_im1 dim1 di dsi, iarray_update ds i ((dsi * dim1 + dmu_i_im1 * dmu_i_im1) div di))))" proof - show ?thesis unfolding basis_reduction_swap_def split Let_def fi_state.simps fim1_state.simps d_state.simps get_nth_im1_def get_nth_i_def update_i_def update_im1_def dec_i_def by simp qed definition basis_reduction_step where "basis_reduction_step upw i state = (if i = 0 then (True, Suc i, inc_state state) else let state' = basis_reduction_add_rows n upw i state; di = d_state state' i; dsi = d_state state' (Suc i); dim1 = d_state state' (i - 1); (num,denom) = quotient_of \ in if di * di * denom \ num * dim1 * dsi then (True, Suc i, inc_state state') else basis_reduction_swap i state')" partial_function (tailrec) basis_reduction_main where [code]: "basis_reduction_main upw i state = (if i < m then case basis_reduction_step upw i state of (upw',i',state') \ basis_reduction_main upw' i' state' else state)" definition "initial_state = (let dmus = d\_impl fs_init; ds = IArray.of_fun (\ i. if i = 0 then 1 else let i1 = i - 1 in dmus !! i1 !! i1) (Suc m); dmus' = IArray.of_fun (\ i. let row_i = dmus !! i in IArray.of_fun (\ j. row_i !! j) i) m in (([], fs_init), dmus', ds) :: LLL_dmu_d_state)" end definition "basis_reduction \ n fs = (let m = length fs in basis_reduction_main \ n m True 0 (initial_state m fs))" definition "reduce_basis \ fs = (case fs of Nil \ fs | Cons f _ \ fs_state (basis_reduction \ (dim_vec f) fs))" definition "short_vector \ fs = hd (reduce_basis \ fs)" lemma map_rev_Suc: "map f (rev [0.. int vec list \ bool" where "mu_repr mu fs = (mu = IArray.of_fun (\ i. IArray.of_fun (d\ fs i) i) m)" definition d_repr :: "int iarray \ int vec list \ bool" where "d_repr ds fs = (ds = IArray.of_fun (d fs) (Suc m))" fun LLL_impl_inv :: "LLL_dmu_d_state \ nat \ int vec list \ bool" where "LLL_impl_inv (f,mu,ds) i fs = (list_repr i f (map (\ j. fs ! j) [0.. d_repr ds fs \ mu_repr mu fs)" context fixes state i fs upw f mu ds assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and state: "state = (f,mu,ds)" begin lemma to_list_repr: "list_repr i f (map ((!) fs) [0.. fs ii j" unfolding to_mu_repr[unfolded mu_repr_def] state using ii j by auto lemma fi_state: "i < m \ fi_state state = fs ! i" using get_nth_i[OF to_list_repr(1)] unfolding state by auto lemma fim1_state: "i < m \ i \ 0 \ fim1_state state = fs ! (i - 1)" using get_nth_im1[OF to_list_repr(1)] unfolding state by auto lemma d_state: "ii \ m \ d_state state ii = d fs ii" using to_d_repr[unfolded d_repr_def] state unfolding state by (auto simp: nth_append) lemma fs_state: "length fs = m \ fs_state state = fs" using of_list_repr[OF to_list_repr(1)] unfolding state by (auto simp: o_def intro!: nth_equalityI) lemma LLL_state_inc_state: assumes i: "i < m" shows "LLL_impl_inv (inc_state state) (Suc i) fs" "fs_state (inc_state state) = fs_state state" proof - from LLL_invD[OF inv] have len: "length fs = m" by auto note inc = inc_i[OF to_list_repr(1)] from inc i impl show "LLL_impl_inv (inc_state state) (Suc i) fs" unfolding state by auto from of_list_repr[OF inc(1)] of_list_repr[OF to_list_repr(1)] i show "fs_state (inc_state state) = fs_state state" unfolding state by auto qed end end context LLL_with_assms begin lemma basis_reduction_add_rows_loop_impl: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant True i fs" and mu_small: "\_small_row i fs j" and res: "LLL_Impl.basis_reduction_add_rows_loop n state i j (map ((!) fs) (rev [0 ..< j])) = state'" (is "LLL_Impl.basis_reduction_add_rows_loop n state i j (?mapf fs j) = _") and j: "j \ i" and i: "i < m" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i fs'" "basis_reduction_add_rows_loop i fs j = fs'" proof (atomize(full), insert assms(1-6), induct j arbitrary: fs state) case (0 fs state) from LLL_invD[OF 0(2)] have len: "length fs = m" by auto from fs_state[OF 0(1-2) _ len] have "fs_state state = fs" by (cases state, auto) thus ?case using 0 i fs' by auto next case (Suc j fs state) hence j: "j < i" and jj: "j \ i" and id: "(j < i) = True" by auto obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto) note Linv = Suc(3) note inv = LLL_invD[OF Linv] note impl = Suc(2) from fi_state[OF impl Linv state i] have fi: "fi_state state = fs ! i" by auto have id: "Suc j - 1 = j" by simp note mu = dmu_ij_state[OF impl Linv state j i] let ?c = "round (\ fs i j)" - interpret fs: fs_int' n m fs_init \ True i fs - by standard (use Linv in auto) + note Linvw = LLL_inv_imp_w[OF Linv] + interpret fs: fs_int' n m fs_init fs + by standard (use Linvw in auto) have floor: "round_num_denom (d\ fs i j) (d fs (Suc j)) = round (fs.gs.\ i j)" using jj i inv unfolding d\_def d_def by (intro fs.round_num_denom_d\_d[unfolded fs.d\_def fs.d_def]) auto - from LLL_d_pos[OF Linv] j i have dj: "d fs (Suc j) > 0" by auto - note updates = d_d\_add_row[OF Linv i j refl] + from LLL_d_pos[OF Linvw] j i have dj: "d fs (Suc j) > 0" by auto + note updates = d_d\_add_row[OF Linvw i j refl] note d_state = d_state[OF impl Linv state] from d_state[of "Suc j"] j i have djs: "d_state state (Suc j) = d fs (Suc j)" by auto note res = Suc(5)[unfolded floor map_rev_Suc djs append.simps LLL_Impl.basis_reduction_add_rows_loop.simps fi Let_def mu id int_times_rat_def] show ?case proof (cases "?c = 0") case True from res[unfolded True] have res: "LLL_Impl.basis_reduction_add_rows_loop n state i j (?mapf fs j) = state'" by simp - note step = Linv basis_reduction_add_row_main_0[OF Linv i j True Suc(4)] + note step = Linv basis_reduction_add_row_main_0[OF Linvw i j True Suc(4)] show ?thesis using Suc(1)[OF impl step(1-2) res _ i] j True by auto next case False hence id: "(?c = 0) = False" by auto from i j have jm: "j < m" by auto have idd: "vec n (\ia. fs ! i $ ia - ?c * fs ! j $ ia) = fs ! i - ?c \\<^sub>v fs ! j" by (intro eq_vecI, insert inv(4)[OF i] inv(4)[OF jm], auto) define fi' where "fi' = fs ! i - ?c \\<^sub>v fs ! j" obtain fs'' where fs'': "fs[i := fs ! i - ?c \\<^sub>v fs ! j] = fs''" by auto - note step = basis_reduction_add_row_main[OF Linv i j fs''[symmetric]] + note step = basis_reduction_add_row_main[OF Linvw i j fs''[symmetric]] + note Linvw2 = step(1) + note step = step(2)[OF Linv] step(3,5-) note updates = updates[where c = ?c, unfolded fs''] have map_id_f: "?mapf fs j = ?mapf fs'' j" by (rule nth_equalityI, insert j i, auto simp: rev_nth fs''[symmetric]) have nth_id: "[0.. fs'' i) i" (is "_ = ?mu'i") proof (rule iarray_cong', goal_cases) case (1 jj) from 1 j i have jm: "j < m" by auto show ?case unfolding dmu_ij_state[OF impl Linv state 1 i] using dmu_ij_state[OF impl Linv state _ jm] by (subst updates(2)[OF i 1], auto) qed { fix ii assume ii: "ii < m" "ii \ i" hence "(IArray.of_fun (\i. IArray.of_fun (d\ fs i) i) m) !! ii = IArray.of_fun (d\ fs ii) ii" by auto also have "\ = IArray.of_fun (d\ fs'' ii) ii" proof (rule iarray_cong', goal_cases) case (1 j) with ii have j: "Suc j \ m" by auto show ?case unfolding updates(2)[OF ii(1) 1] using ii by auto qed finally have "(IArray.of_fun (\i. IArray.of_fun (d\ fs i) i) m) !! ii = IArray.of_fun (d\ fs'' ii) ii" by auto } note ii = this let ?mu'' = "iarray_update mu i (IArray.of_fun (d\ fs'' i) i)" have new_array: "?mu'' = IArray.of_fun (\ i. IArray.of_fun (d\ fs'' i) i) m" unfolding iarray_update_of_fun to_mu_repr[OF impl Linv state, unfolded mu_repr_def] by (rule iarray_cong', insert ii, auto) have d': "(map (?d fs) (rev [0..\<^sub>v fs ! j = fs'' ! i" unfolding fs''[symmetric] using inv(6) i by auto note res = res[unfolded mu' mu d'] show ?thesis unfolding basis_reduction_add_rows_loop.simps Let_def id if_False fs'' proof (rule Suc(1)[OF _ step(1,2) res _ i]) note list_repr = to_list_repr[OF impl Linv state] from i have ii: "i < length [0.._small_row i fs j" and res: "LLL_Impl.basis_reduction_add_rows_loop n state i j (map ((!) fs) (rev [0 ..< j])) = state'" (is "LLL_Impl.basis_reduction_add_rows_loop n state i j (?mapf fs j) = _") and j: "j \ i" and i: "i < m" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i fs'" "LLL_invariant False i fs'" "LLL_measure i fs' = LLL_measure i fs" "basis_reduction_add_rows_loop i fs j = fs'" using basis_reduction_add_rows_loop_impl[OF assms] basis_reduction_add_rows_loop[OF inv mu_small _ i j] by blast+ lemma basis_reduction_add_rows_impl: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and res: "LLL_Impl.basis_reduction_add_rows n upw i state = state'" and i: "i < m" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i fs'" "basis_reduction_add_rows upw i fs = fs'" proof (atomize(full), goal_cases) case 1 obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto) note def = LLL_Impl.basis_reduction_add_rows_def basis_reduction_add_rows_def show ?case proof (cases upw) case False from LLL_invD[OF inv] have len: "length fs = m" by auto from fs_state[OF impl inv state len] have "fs_state state = fs" by auto with assms False show ?thesis by (auto simp: def) next case True with inv have "LLL_invariant True i fs" by auto note start = this \_small_row_refl[of i fs] have id: "small_fs_state state = map (\ i. fs ! i) (rev [0.. \ * sq_norm (gso fs i)" and i: "i < m" and i0: "i \ 0" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i' fs'" (is ?g1) "basis_reduction_swap i fs = (upw',i',fs')" (is ?g2) proof - + note invw = LLL_inv_imp_w[OF inv] from i i0 have ii: "i - 1 < i" and le_m: "i - 1 \ m" "i \ m" "Suc i \ m" by auto obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto) note dmu_ij_state = dmu_ij_state[OF impl inv state] note d_state = d_state[OF impl inv state] note res = res[unfolded LLL_Impl.basis_reduction_swap_def Let_def split state, folded state, unfolded fi_state[OF impl inv state i] fim1_state[OF impl inv state i i0]] note state_id = dmu_ij_state[OF ii i] note d_state_i = d_state[OF le_m(1)] d_state[OF le_m(2)] d_state[OF le_m(3)] from LLL_invD[OF inv] have len: "length fs = m" by auto from fs_state[OF impl inv state len] have fs: "fs_state state = fs" by auto obtain fs'' where fs'': "fs[i := fs ! (i - 1), i - 1 := fs ! i] = fs''" by auto let ?r = rat_of_int let ?d = "d fs" let ?d' = "d fs''" let ?dmus = "dmu_ij_state state" - let ?ds = "d_state state" - note swap = basis_reduction_swap_main[OF inv i i0 cond refl, unfolded fs''] - interpret fs: fs_int' n m fs_init \ False i fs - by standard (use inv in auto) - interpret fs'': fs_int' n m fs_init \ False "i - 1" fs'' - by standard (use swap in auto) + let ?ds = "d_state state" + note swap = basis_reduction_swap_main[OF invw disjI1[OF inv] i i0 cond refl, unfolded fs''] + note invw2 = swap(1) + note swap = swap(2)[OF inv] swap(3-) + interpret fs: fs_int' n m fs_init fs + by standard (use invw in auto) + interpret fs'': fs_int' n m fs_init fs'' + by standard (use invw2 in auto) note dmu = fs.d\ note dmu' = fs''.d\ note inv' = LLL_invD[OF inv] have fi: "fs ! (i - 1) = fs'' ! i" "fs ! i = fs'' ! (i - 1)" unfolding fs''[symmetric] using inv'(6) i i0 by auto from res have upw': "upw' = False" "i' = i - 1" by auto let ?dmu_repr' = "swap_mu m mu i (?dmus i (i - 1)) (?d (i - 1)) (?d i) (?d (Suc i))" let ?d'i = "(?d (Suc i) * ?d (i - 1) + ?dmus i (i - 1) * ?dmus i (i - 1)) div (?d i)" from res[unfolded fi d_state_i] have res: "upw' = False" "i' = i - 1" "state' = (dec_i (update_im1 (update_i f (fs'' ! i)) (fs'' ! (i - 1))), ?dmu_repr', iarray_update ds i ?d'i)" by auto from i have ii: "i < length [0.. {i-1,i}", auto) finally have f_repr: "list_repr (i - 1) ?fr (map ((!) fs'') [0.._swap[OF inv i i0 cond fs''[symmetric]] + note updates = d_d\_swap[OF invw disjI1[OF inv] i i0 cond fs''[symmetric]] note dmu_ii = dmu_ij_state[OF \i - 1 < i\ i] show ?g1 unfolding fs_id LLL_impl_inv.simps res proof (intro conjI f_repr) show "d_repr (iarray_update ds i ?d'i) fs''" unfolding d_repr[unfolded d_repr_def] d_repr_def iarray_update_of_fun dmu_ii by (rule iarray_cong', subst updates(1), auto simp: nth_append intro: arg_cong) show "mu_repr ?dmu_repr' fs''" unfolding mu_repr_def swap_mu_def Let_def dmu_ii proof (rule iarray_cong', goal_cases) case ii: (1 ii) show ?case proof (cases "ii < i - 1") case small: True hence id: "(ii = i) = False" "(ii = i - 1) = False" "(i < ii) = False" "(ii < i - 1) = True" by auto have mu: "mu !! ii = IArray.of_fun (d\ fs ii) ii" using ii unfolding mu_def by auto show ?thesis unfolding id if_True if_False mu by (rule iarray_cong', insert small ii i i0, subst updates(2), simp_all, linarith) next case False hence iFalse: "(ii < i - 1) = False" by auto show ?thesis unfolding iFalse if_False if_distrib[of "\ f. IArray.of_fun f ii", symmetric] dmu_ij_state.simps[of f mu ds, folded state, symmetric] proof (rule iarray_cong', goal_cases) case j: (1 j) note upd = updates(2)[OF ii j] dmu_ii dmu_ij_state[OF j ii] if_distrib[of "\ x. x j"] note simps = dmu_ij_state[OF _ ii] dmu_ij_state[OF _ im1] dmu_ij_state[OF _ i] from False consider (I) "ii = i" "j = i - 1" | (Is) "ii = i" "j \ i - 1" | (Im1) "ii = i - 1" | (large) "ii > i" by linarith thus ?case proof (cases) case (I) show ?thesis unfolding upd using I by auto next case (Is) show ?thesis unfolding upd using Is j simps by auto next case (Im1) hence id: "(i < ii) = False" "(ii = i) = False" "(ii = i - 1) = True" using i0 by auto show ?thesis unfolding upd unfolding id if_False if_True by (rule simps, insert j Im1, auto) next case (large) hence "i - 1 < ii" "i < ii" by auto note simps = simps(1)[OF this(1)] simps(1)[OF this(2)] from large have id: "(i < ii) = True" "(ii = i - 1) = False" "\ x. (ii = i \ x) = False" by auto show ?thesis unfolding id if_True if_False upd simps by auto qed qed qed qed qed show ?g2 unfolding fs_id fs''[symmetric] basis_reduction_swap_def unfolding res .. qed lemma basis_reduction_swap: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant False i fs" and res: "LLL_Impl.basis_reduction_swap m i state = (upw',i',state')" and cond: "sq_norm (gso fs (i - 1)) > \ * sq_norm (gso fs i)" and i: "i < m" and i0: "i \ 0" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i' fs'" "LLL_invariant upw' i' fs'" "LLL_measure i' fs' < LLL_measure i fs" "basis_reduction_swap i fs = (upw',i',fs')" using basis_reduction_swap_impl[OF assms] basis_reduction_swap[OF inv _ cond i i0] by blast+ lemma basis_reduction_step_impl: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and res: "LLL_Impl.basis_reduction_step \ n m upw i state = (upw',i',state')" and i: "i < m" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i' fs'" "basis_reduction_step upw i fs = (upw',i',fs')" proof (atomize(full), goal_cases) case 1 obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto) note def = LLL_Impl.basis_reduction_step_def basis_reduction_step_def from LLL_invD[OF inv] have len: "length fs = m" by auto from fs_state[OF impl inv state len] have fs: "fs_state state = fs" by auto show ?case proof (cases "i = 0") case True from LLL_state_inc_state[OF impl inv state i] i assms increase_i[OF inv i True] True res fs' fs show ?thesis by (auto simp: def) next case False hence id: "(i = 0) = False" by auto obtain state'' where state'': "LLL_Impl.basis_reduction_add_rows n upw i state = state''" by auto define fs'' where fs'': "fs'' = fs_state state''" obtain f mu ds where state: "state'' = (f,mu,ds)" by (cases state'', auto) from basis_reduction_add_rows[OF impl inv state'' i fs''] have inv: "LLL_invariant False i fs''" and meas: "LLL_measure i fs = LLL_measure i fs''" and impl: "LLL_impl_inv state'' i fs''" and impl': "basis_reduction_add_rows upw i fs = fs''" by auto + note invw = LLL_inv_imp_w[OF inv] obtain num denom where quot: "quotient_of \ = (num,denom)" by force note d_state = d_state[OF impl inv state] from i have le: "i - 1 \ m" " i \ m" "Suc i \ m" by auto note d_state = d_state[OF le(1)] d_state[OF le(2)] d_state[OF le(3)] - interpret fs'': fs_int' n m fs_init \ False i fs'' - by standard (use inv in auto) + interpret fs'': fs_int' n m fs_init fs'' + by standard (use invw in auto) have "i < length fs''" using LLL_invD[OF inv] i by auto note d_sq_norm_comparison = fs''.d_sq_norm_comparison[OF quot this False] note res = res[unfolded def id if_False Let_def state'' quot split d_state this] - note pos = LLL_d_pos[OF inv le(1)] LLL_d_pos[OF inv le(2)] quotient_of_denom_pos[OF quot] + note pos = LLL_d_pos[OF invw le(1)] LLL_d_pos[OF invw le(2)] quotient_of_denom_pos[OF quot] from False have sim1: "Suc (i - 1) = i" by simp let ?r = "rat_of_int" let ?x = "sq_norm (gso fs'' (i - 1))" let ?y = "\ * sq_norm (gso fs'' i)" show ?thesis proof (cases "?x \ ?y") case True from increase_i[OF inv i _ True] True res meas LLL_state_inc_state[OF impl inv state i] fs' fs'' d_def d_sq_norm_comparison fs''.d_def impl' False show ?thesis by (auto simp: def) next case F: False hence gt: "?x > ?y" and id: "(?x \ ?y) = False" by auto from res[unfolded id if_False] d_def d_sq_norm_comparison fs''.d_def id have "LLL_Impl.basis_reduction_swap m i state'' = (upw', i', state')" by auto from basis_reduction_swap[OF impl inv this gt i False fs'] show ?thesis using meas F False by (auto simp: def Let_def impl') qed qed qed lemma basis_reduction_step: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and res: "LLL_Impl.basis_reduction_step \ n m upw i state = (upw',i',state')" and i: "i < m" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' i' fs'" "LLL_invariant upw' i' fs'" "LLL_measure i' fs' < LLL_measure i fs" "basis_reduction_step upw i fs = (upw',i',fs')" using basis_reduction_step_impl[OF assms] basis_reduction_step[OF inv _ i] by blast+ lemma basis_reduction_main_impl: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and res: "LLL_Impl.basis_reduction_main \ n m upw i state = state'" and fs': "fs' = fs_state state'" shows "LLL_impl_inv state' m fs'" "basis_reduction_main (upw,i,fs) = fs'" proof (atomize(full), insert assms(1-3), induct "LLL_measure i fs" arbitrary: i fs upw state rule: less_induct) case (less i fs upw) have id: "LLL_invariant upw i fs = True" using less by auto note res = less(4)[unfolded LLL_Impl.basis_reduction_main.simps[of _ _ _ upw]] note inv = less(3) note impl = less(2) note IH = less(1) show ?case proof (cases "i < m") case i: True obtain i'' state'' upw'' where step: "LLL_Impl.basis_reduction_step \ n m upw i state = (upw'',i'',state'')" (is "?step = _") by (cases ?step, auto) with res i have res: "LLL_Impl.basis_reduction_main \ n m upw'' i'' state'' = state'" by auto note main = basis_reduction_step[OF impl inv step i refl] from IH[OF main(3,1,2) res] main(4) step res show ?thesis by (simp add: i inv basis_reduction_main.simps) next case False from LLL_invD[OF inv] have len: "length fs = m" by auto obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto) from fs_state[OF impl inv state len] have fs: "fs_state state = fs" by auto from False fs res fs' have fs_id: "fs = fs'" by simp from False LLL_invD[OF inv] have i: "i = m" by auto with False res inv impl fs have "LLL_invariant upw m fs' \ LLL_impl_inv state' m fs'" by (auto simp: fs') thus ?thesis unfolding basis_reduction_main.simps[of upw i fs] using False by (auto simp: LLL_invariant_def fs_id) qed qed lemma basis_reduction_main: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs" and res: "LLL_Impl.basis_reduction_main \ n m upw i state = state'" and fs': "fs' = fs_state state'" shows "LLL_invariant True m fs'" "LLL_impl_inv state' m fs'" "basis_reduction_main (upw,i,fs) = fs'" using basis_reduction_main_impl[OF assms] basis_reduction_main[OF inv] by blast+ lemma initial_state: "LLL_impl_inv (initial_state m fs_init) 0 fs_init" (is ?g1) "fs_state (initial_state m fs_init) = fs_init" (is ?g2) proof - have f_repr: "list_repr 0 ([], fs_init) (map ((!) fs_init) [0.. Rn" by auto have 1: "1 = d fs_init 0" unfolding d_def by simp define j where "j = m" have jm: "j \ m" unfolding j_def by auto have 0: "0 = m - j" unfolding j_def by auto interpret fs_init: fs_int_indpt n fs_init by (standard) (use lin_dep in auto) have mu_repr: "mu_repr (IArray.of_fun (\i. IArray.of_fun ((!!) (d\_impl fs_init !! i)) i) m) fs_init" unfolding fs_init.d\_impl mu_repr_def fs_init.d\_def d\_def fs_init.d_def d_def apply(rule iarray_cong') unfolding len[symmetric] by (auto simp add: nth_append) have d_repr: "d_repr (IArray.of_fun (\i. if i = 0 then 1 else d\_impl fs_init !! (i - 1) !! (i - 1)) (Suc m)) fs_init" unfolding fs_init.d\_impl d_repr_def proof (intro iarray_cong', goal_cases) case (1 i) show ?case proof (cases "i = 0") case False hence le: "i - 1 < length fs_init" "i - 1 < i" and id: "(i = 0) = False" "Suc (i - 1) = i" using 1 len by auto show ?thesis unfolding of_fun_nth[OF le(1)] of_fun_nth[OF le(2)] id if_False d\_def fs_init.d\_def fs_init.d_def d_def by (auto simp add: gs.\.simps ) next case True have "d fs_init 0 = 1" unfolding d_def gs.Gramian_determinant_0 by simp thus ?thesis unfolding True by simp qed qed show ?g1 unfolding initial_state_def Let_def LLL_impl_inv.simps id by (intro conjI f_repr mu_repr d_repr) from fs_state[OF this LLL_inv_initial_state] show ?g2 unfolding initial_state_def Let_def by (simp add: of_list_repr_def) qed lemma basis_reduction: assumes res: "basis_reduction \ n fs_init = state" and fs: "fs = fs_state state" shows "LLL_invariant True m fs" "LLL_impl_inv state m fs" "basis_reduction_main (True, 0, fs_init) = fs" using basis_reduction_main[OF initial_state(1) LLL_inv_initial_state res[unfolded basis_reduction_def len Let_def] fs] by auto lemma reduce_basis_impl: "LLL_Impl.reduce_basis \ fs_init = reduce_basis" proof - obtain fs where res: "LLL_Impl.reduce_basis \ fs_init = fs" by blast have "reduce_basis = fs" proof (cases fs_init) case (Cons f) from fs_init[unfolded Cons] have "dim_vec f = n" by auto from res[unfolded LLL_Impl.reduce_basis_def Cons list.simps this, folded Cons] have "fs_state (LLL_Impl.basis_reduction \ n fs_init) = fs" by auto from basis_reduction(3)[OF refl refl, unfolded this] show "reduce_basis = fs" unfolding reduce_basis_def . next case Nil with len have m0: "m = 0" by auto show ?thesis using res unfolding reduce_basis_def LLL_Impl.reduce_basis_def basis_reduction_main.simps using Nil m0 by simp qed with res show ?thesis by simp qed lemma reduce_basis: assumes "LLL_Impl.reduce_basis \ fs_init = fs" shows "lattice_of fs = L" "reduced fs m" "lin_indep fs" "length fs = m" "LLL_invariant True m fs" using reduce_basis_impl assms reduce_basis reduce_basis_inv by metis+ lemma short_vector_impl: "LLL_Impl.short_vector \ fs_init = short_vector" using reduce_basis_impl unfolding LLL_Impl.short_vector_def short_vector_def by simp lemma short_vector: assumes res: "LLL_Impl.short_vector \ fs_init = v" and m0: "m \ 0" shows "v \ carrier_vec n" "v \ L - {0\<^sub>v n}" "h \ L - {0\<^sub>v n} \ rat_of_int (sq_norm v) \ \ ^ (m - 1) * rat_of_int (sq_norm h)" "v \ 0\<^sub>v j" using short_vector[OF assms[unfolded short_vector_impl]] by metis+ end end diff --git a/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy b/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy --- a/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy +++ b/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy @@ -1,1237 +1,1274 @@ (* Authors: Maximilian Haslbeck René Thiemann License: BSD *) subsection \Explicit Bounds for Size of Numbers that Occur During LLL Algorithm\ text \The LLL invariant does not contain bounds on the number that occur during the execution. We here strengthen the invariant so that it enforces bounds on the norms of the $f_i$ and $g_i$ and we prove that the stronger invariant is maintained throughout the execution of the LLL algorithm. Based on the stronger invariant we prove bounds on the absolute values of the $\mu_{i,j}$, and on the absolute values of the numbers in the vectors $f_i$ and $g_i$. Moreover, we further show that also the denominators in all of these numbers doesn't grow to much. Finally, we prove that each number (i.e., numerator or denominator) during the execution can be represented with at most ${\cal O}(m \cdot \log(M \cdot n))$ bits, where $m$ is the number of input vectors, $n$ is the dimension of the input vectors, and $M$ is the maximum absolute value of all numbers in the input vectors. Hence, each arithmetic operation in the LLL algorithm can be performed in polynomial time.\ theory LLL_Number_Bounds imports LLL Gram_Schmidt_Int begin context LLL begin text \The bounds for the $f_i$ distinguishes whether we are inside or outside the inner for-loop.\ definition f_bound :: "bool \ nat \ int vec list \ bool" where "f_bound outside ii fs = (\ i < m. sq_norm (fs ! i) \ (if i \ ii \ outside then int (N * m) else int (4 ^ (m - 1) * N ^ m * m * m)))" +definition g_bnd :: "rat \ int vec list \ bool" where + "g_bnd B fs = (\ i < m. sq_norm (gso fs i) \ B)" + definition "\_bound_row fs bnd i = (\ j \ i. (\ fs i j)^2 \ bnd)" abbreviation "\_bound_row_inner fs i j \ \_bound_row fs (4 ^ (m - 1 - j) * of_nat (N ^ (m - 1) * m)) i" definition "LLL_bound_invariant outside upw i fs = (LLL_invariant upw i fs \ f_bound outside i fs \ g_bound fs)" lemma bound_invD: assumes "LLL_bound_invariant outside upw i fs" shows "LLL_invariant upw i fs" "f_bound outside i fs" "g_bound fs" using assms unfolding LLL_bound_invariant_def by auto lemma bound_invI: assumes "LLL_invariant upw i fs" "f_bound outside i fs" "g_bound fs" shows "LLL_bound_invariant outside upw i fs" using assms unfolding LLL_bound_invariant_def by auto lemma \_bound_rowI: assumes "\ j. j \ i \ (\ fs i j)^2 \ bnd" shows "\_bound_row fs bnd i" using assms unfolding \_bound_row_def by auto lemma \_bound_rowD: assumes "\_bound_row fs bnd i" "j \ i" shows "(\ fs i j)^2 \ bnd" using assms unfolding \_bound_row_def by auto lemma \_bound_row_1: assumes "\_bound_row fs bnd i" shows "bnd \ 1" proof - interpret gs1: gram_schmidt_fs n "RAT fs" . show ?thesis using \_bound_rowD[OF assms, of i] by (auto simp: gs1.\.simps) qed lemma reduced_\_bound_row: assumes red: "reduced fs i" and ii: "ii < i" shows "\_bound_row fs 1 ii" proof (intro \_bound_rowI) fix j assume "j \ ii" interpret gs1: gram_schmidt_fs n "RAT fs" . show "(\ fs ii j)^2 \ 1" proof (cases "j < ii") case True from red[unfolded gram_schmidt_fs.reduced_def, THEN conjunct2, rule_format, OF ii True] have "abs (\ fs ii j) \ 1/2" by auto from mult_mono[OF this this] show ?thesis by (auto simp: power2_eq_square) qed (auto simp: gs1.\.simps) qed lemma f_bound_True_arbitrary: assumes "f_bound True ii fs" shows "f_bound outside j fs" unfolding f_bound_def proof (intro allI impI, rule ccontr, goal_cases) case (1 i) from 1 have nz: "\fs ! i\\<^sup>2 \ 0" by (auto split: if_splits) hence gt: "\fs ! i\\<^sup>2 > 0" using sq_norm_vec_ge_0[of "fs ! i"] by auto from assms(1)[unfolded f_bound_def, rule_format, OF 1(1)] have one: "\fs ! i\\<^sup>2 \ int (N * m) * 1" by auto from less_le_trans[OF gt one] have N0: "N \ 0" by (cases "N = 0", auto) note one also have "int (N * m) * 1 \ int (N * m) * int (4 ^ (m - 1) * N ^ (m - 1) * m)" by (rule mult_left_mono, unfold of_nat_mult, intro mult_ge_one, insert 1 N0, auto) also have "\ = int (4 ^ (m - 1) * N ^ (Suc (m - 1)) * m * m)" unfolding of_nat_mult by simp also have "Suc (m - 1) = m" using 1 by simp finally show ?case using one 1 by (auto split: if_splits) qed context fixes fs :: "int vec list" assumes lin_indep: "lin_indep fs" and len: "length fs = m" begin interpretation fs: fs_int_indpt n fs by (standard) (use lin_indep in simp) lemma sq_norm_fs_mu_g_bound: assumes i: "i < m" and mu_bound: "\_bound_row fs bnd i" and g_bound: "g_bound fs" shows "of_int \fs ! i\\<^sup>2 \ of_nat (Suc i * N) * bnd" proof - have "of_int \fs ! i\\<^sup>2 = (\j\[0.. fs i j)\<^sup>2 * \gso fs j\\<^sup>2)" by (rule fs.sq_norm_fs_via_sum_mu_gso) (use assms lin_indep len in auto) also have "\ \ (\j\[0.. i" by auto from g_bound[unfolded g_bound_def] i ji have GB: "sq_norm (gso fs j) \ of_nat N" by auto show ?case by (rule mult_mono, insert \_bound_rowD[OF mu_bound ji] GB order.trans[OF zero_le_power2], auto) qed also have "\ = of_nat (Suc i) * (bnd * of_nat N)" unfolding sum_list_triv length_upt by simp also have "\ = of_nat (Suc i * N) * bnd" unfolding of_nat_mult by simp finally show ?thesis . qed end lemma increase_i_bound: assumes LLL: "LLL_bound_invariant True upw i fs" and i: "i < m" and upw: "upw \ i = 0" and red_i: "i \ 0 \ sq_norm (gso fs (i - 1)) \ \ * sq_norm (gso fs i)" shows "LLL_bound_invariant True True (Suc i) fs" proof - from bound_invD[OF LLL] have LLL: "LLL_invariant upw i fs" and "f_bound True i fs" and gbnd: "g_bound fs" by auto hence fbnd: "f_bound True (Suc i) fs" by (auto simp: f_bound_def) from increase_i[OF LLL i upw red_i] have inv: "LLL_invariant True (Suc i) fs" and "LLL_measure (Suc i) fs < LLL_measure i fs" (is ?g2) by auto show "LLL_bound_invariant True True (Suc i) fs" by (rule bound_invI[OF inv fbnd gbnd]) qed text \Addition step preserves @{term "LLL_bound_invariant False"}\ lemma basis_reduction_add_row_main_bound: assumes Linv: "LLL_bound_invariant False True i fs" and i: "i < m" and j: "j < i" and c: "c = round (\ fs i j)" and fs': "fs' = fs[ i := fs ! i - c \\<^sub>v fs ! j]" and mu_small: "\_small_row i fs (Suc j)" and mu_bnd: "\_bound_row_inner fs i (Suc j)" shows "LLL_bound_invariant False True i fs'" "\_bound_row_inner fs' i j" proof (rule bound_invI) from bound_invD[OF Linv] have Linv: "LLL_invariant True i fs" and fbnd: "f_bound False i fs" and gbnd: "g_bound fs" by auto - note main = basis_reduction_add_row_main[OF Linv i j fs'] + note Linvw = LLL_inv_imp_w[OF Linv] + note main = basis_reduction_add_row_main[OF Linvw i j fs'] + note main = main(2)[OF Linv] main(3,5-) note main = main(1) main(2)[OF c mu_small] main(3-) show Linv': "LLL_invariant True i fs'" by fact define bnd :: rat where bnd: "bnd = 4 ^ (m - 1 - Suc j) * of_nat (N ^ (m - 1) * m)" note mu_bnd = mu_bnd[folded bnd] note inv = LLL_invD[OF Linv] let ?mu = "\ fs" let ?mu' = "\ fs'" from j have "j \ i" by simp let ?R = rat_of_int (* (squared) mu bound will increase at most by factor 4 *) have mu_bound_factor: "\_bound_row fs' (4 * bnd) i" proof (intro \_bound_rowI) fix k assume ki: "k \ i" from \_bound_rowD[OF mu_bnd] have bnd_i: "\ j. j \ i \ (?mu i j)^2 \ bnd" by auto have bnd_ik: "(?mu i k)\<^sup>2 \ bnd" using bnd_i[OF ki] by auto have bnd_ij: "(?mu i j)\<^sup>2 \ bnd" using bnd_i[OF \j \ i\] by auto from \_bound_row_1[OF mu_bnd] have bnd1: "bnd \ 1" "bnd \ 0" by auto show "(?mu' i k)\<^sup>2 \ 4 * bnd" proof (cases "k > j") case True show ?thesis by (subst main(5), (insert True ki i bnd1, auto)[3], intro order.trans[OF bnd_ik], auto) next case False hence kj: "k \ j" by auto show ?thesis proof (cases "k = j") case True have small: "abs (?mu' i k) \ 1/2" using main(2) j unfolding True \_small_row_def by auto show ?thesis using mult_mono[OF small small] using bnd1 by (auto simp: power2_eq_square) next case False with kj have k_j: "k < j" by auto define M where "M = max (abs (?mu i k)) (max (abs (?mu i j)) (1/2))" have M0: "M \ 0" unfolding M_def by auto let ?new_mu = "?mu i k - ?R c * ?mu j k" have "abs ?new_mu \ abs (?mu i k) + abs (?R c * ?mu j k)" by simp also have "\ = abs (?mu i k) + abs (?R c) * abs (?mu j k)" unfolding abs_mult .. also have "\ \ abs (?mu i k) + (abs (?mu i j) + 1/2) * (1/2)" proof (rule add_left_mono[OF mult_mono], unfold c) show "\?R (round (?mu i j))\ \ \?mu i j\ + 1 / 2" unfolding round_def by linarith from inv(10)[unfolded gram_schmidt_fs.reduced_def, THEN conjunct2, rule_format, OF \j < i\ k_j] show "\?mu j k\ \ 1/2" . qed auto also have "\ \ M + (M + M) * (1/2)" by (rule add_mono[OF _ mult_right_mono[OF add_mono]], auto simp: M_def) also have "\ = 2 * M" by auto finally have le: "abs ?new_mu \ 2 * M" . have "(?mu' i k)\<^sup>2 = ?new_mu\<^sup>2" by (subst main(5), insert kj False i j, auto) also have "\ \ (2 * M)^2" unfolding abs_le_square_iff[symmetric] using le M0 by auto also have "\ = 4 * M^2" by simp also have "\ \ 4 * bnd" proof (rule mult_left_mono) show "M^2 \ bnd" using bnd_ij bnd_ik bnd1 unfolding M_def by (auto simp: max_def power2_eq_square) qed auto finally show ?thesis . qed qed qed also have "4 * bnd = (4 ^ (1 + (m - 1 - Suc j)) * of_nat (N ^ (m - 1) * m))" unfolding bnd by simp also have "1 + (m - 1 - Suc j) = m - 1 - j" using i j by auto finally show bnd: "\_bound_row_inner fs' i j" by auto show gbnd: "g_bound fs'" using gbnd unfolding g_bound_def using main(4) by auto note inv' = LLL_invD[OF Linv'] show "f_bound False i fs'" unfolding f_bound_def proof (intro allI impI, goal_cases) case (1 jj) show ?case proof (cases "jj = i") case False with 1 fbnd[unfolded f_bound_def] have "\fs ! jj\\<^sup>2 \ int (N * m)" by auto thus ?thesis unfolding fs' using False 1 inv(2-) by auto next case True have "of_int \fs' ! i\\<^sup>2 = \RAT fs' ! i\\<^sup>2" using i inv' by (auto simp: sq_norm_of_int) also have "... \ rat_of_nat (Suc i * N) * (4 ^ (m - 1 - j) * rat_of_nat (N ^ (m - 1) * m))" using sq_norm_fs_mu_g_bound[OF inv'(1,6) i bnd gbnd] i inv' unfolding sq_norm_of_int[symmetric] by (auto simp: ac_simps) also have "\ = rat_of_int ( int (Suc i * N) * (4 ^ (m - 1 - j) * (N ^ (m - 1) * m)))" by simp finally have "\fs' ! i\\<^sup>2 \ int (Suc i * N) * (4 ^ (m - 1 - j) * (N ^ (m - 1) * m))" by linarith also have "\ = int (Suc i) * 4 ^ (m - 1 - j) * (int N ^ (Suc (m - 1))) * int m" unfolding of_nat_mult by (simp add: ac_simps) also have "\ = int (Suc i) * 4 ^ (m - 1 - j) * int N ^ m * int m" using i j by simp also have "\ \ int m * 4 ^ (m - 1) * int N ^ m * int m" by (rule mult_right_mono[OF mult_right_mono[OF mult_mono[OF _ pow_mono_exp]]], insert i, auto) finally have "\fs' ! i\\<^sup>2 \ int (4 ^ (m - 1) * N ^ m * m * m)" unfolding of_nat_mult by (simp add: ac_simps) thus ?thesis unfolding True by auto qed qed qed end context LLL_with_assms begin subsubsection \@{const LLL_bound_invariant} is maintained during execution of @{const reduce_basis}\ lemma basis_reduction_add_rows_enter_bound: assumes binv: "LLL_bound_invariant True True i fs" and i: "i < m" shows "LLL_bound_invariant False True i fs" "\_bound_row_inner fs i i" proof (rule bound_invI) from bound_invD[OF binv] have Linv: "LLL_invariant True i fs" (is ?g1) and fbnd: "f_bound True i fs" and gbnd: "g_bound fs" by auto - interpret fs: fs_int' n m fs_init \ True i fs - by standard (use Linv in auto) + note Linvw = LLL_inv_imp_w[OF Linv] + interpret fs: fs_int' n m fs_init fs + by standard (use Linvw in auto) note inv = LLL_invD[OF Linv] show "LLL_invariant True i fs" by fact show fbndF: "f_bound False i fs" using f_bound_True_arbitrary[OF fbnd] . - have N0: "N > 0" using LLL_inv_N_pos[OF Linv gbnd] i by auto + have N0: "N > 0" using LLL_inv_N_pos[OF Linvw gbnd] i by auto { fix j assume ji: "j < i" have "(\ fs i j)\<^sup>2 \ gs.Gramian_determinant (RAT fs) j * \RAT fs ! i\\<^sup>2" using ji i inv by (intro fs.gs.mu_bound_Gramian_determinant) (auto) also have "gs.Gramian_determinant (RAT fs) j = of_int (d fs j)" unfolding d_def by (subst fs.of_int_Gramian_determinant, insert ji i inv(2-), auto simp: set_conv_nth) also have "\RAT fs ! i\\<^sup>2 = of_int \fs ! i\\<^sup>2" using i inv(2-) by (auto simp: sq_norm_of_int) also have "of_int (d fs j) * \ \ rat_of_nat (N^j) * of_int \fs ! i\\<^sup>2" - by (rule mult_right_mono, insert ji i d_approx[OF Linv gbnd, of j], auto) + by (rule mult_right_mono, insert ji i d_approx[OF Linvw gbnd, of j], auto) also have "\ \ rat_of_nat (N^(m-2)) * of_int (int (N * m))" by (intro mult_mono, unfold of_nat_le_iff of_int_le_iff, rule pow_mono_exp, insert fbnd[unfolded f_bound_def, rule_format, of i] N0 ji i, auto) also have "\ = rat_of_nat (N^(m-2) * N * m)" by simp also have "N^(m-2) * N = N^(Suc (m - 2))" by simp also have "Suc (m - 2) = m - 1" using ji i by auto finally have "(\ fs i j)\<^sup>2 \ of_nat (N ^ (m - 1) * m)" . } note mu_bound = this show mu_bnd: "\_bound_row_inner fs i i" proof (rule \_bound_rowI) fix j assume j: "j \ i" have "(\ fs i j)\<^sup>2 \ 1 * of_nat (N ^ (m - 1) * m)" proof (cases "j = i") case False with mu_bound[of j] j show ?thesis by auto next case True show ?thesis unfolding True fs.gs.\.simps using i N0 by auto qed also have "\ \ 4 ^ (m - 1 - i) * of_nat (N ^ (m - 1) * m)" by (rule mult_right_mono, auto) finally show "(\ fs i j)\<^sup>2 \ 4 ^ (m - 1 - i) * rat_of_nat (N ^ (m - 1) * m)" . qed show "g_bound fs" by fact qed lemma basis_basis_reduction_add_rows_loop_leave: assumes binv: "LLL_bound_invariant False True i fs" and mu_small: "\_small_row i fs 0" and mu_bnd: "\_bound_row_inner fs i 0" and i: "i < m" shows "LLL_bound_invariant True False i fs" proof - note Linv = bound_invD(1)[OF binv] from mu_small have mu_small: "\_small fs i" unfolding \_small_row_def \_small_def by auto note inv = LLL_invD[OF Linv] interpret gs1: gram_schmidt_fs_int n "RAT fs" by (standard) (use inv gs.lin_indpt_list_def in \auto simp add: vec_hom_Ints\) note fbnd = bound_invD(2)[OF binv] note gbnd = bound_invD(3)[OF binv] { fix ii assume ii: "ii < m" have "\fs ! ii\\<^sup>2 \ int (N * m)" proof (cases "ii = i") case False thus ?thesis using ii fbnd[unfolded f_bound_def] by auto next case True have row: "\_bound_row fs 1 i" proof (intro \_bound_rowI) fix j assume j: "j \ i" from mu_small[unfolded \_small_def, rule_format, of j] have "abs (\ fs i j) \ 1" using j unfolding \_small_def by (cases "j = i", force simp: gs1.\.simps, auto) from mult_mono[OF this this] show "(\ fs i j)\<^sup>2 \ 1" by (auto simp: power2_eq_square) qed have "rat_of_int \fs ! i\\<^sup>2 \ rat_of_int (int (Suc i * N))" using sq_norm_fs_mu_g_bound[OF inv(1,6) i row gbnd] by auto hence "\fs ! i\\<^sup>2 \ int (Suc i * N)" by linarith also have "\ = int N * int (Suc i)" unfolding of_nat_mult by simp also have "\ \ int N * int m" by (rule mult_left_mono, insert i, auto) also have "\ = int (N * m)" by simp finally show ?thesis unfolding True . qed } hence f_bound: "f_bound True i fs" unfolding f_bound_def by auto with binv show ?thesis using basis_reduction_add_row_done[OF Linv i assms(2)] by (auto simp: LLL_bound_invariant_def) qed lemma basis_reduction_add_rows_loop_bound: assumes binv: "LLL_bound_invariant False True i fs" and mu_small: "\_small_row i fs j" and mu_bnd: "\_bound_row_inner fs i j" and res: "basis_reduction_add_rows_loop i fs j = fs'" and i: "i < m" and j: "j \ i" shows "LLL_bound_invariant True False i fs'" using assms proof (induct j arbitrary: fs) case (0 fs) note binv = 0(1) from basis_basis_reduction_add_rows_loop_leave[OF 0(1-3) i] 0(4) show ?case by auto next case (Suc j fs) note binv = Suc(2) note Linv = bound_invD(1)[OF binv] + note Linvw = LLL_inv_imp_w[OF Linv] from Suc have j: "j < i" by auto let ?c = "round (\ fs i j)" note step = basis_reduction_add_row_main_bound[OF Suc(2) i j refl refl Suc(3-4)] - note step' = basis_reduction_add_row_main(1,2,3)[OF Linv i j refl] + note step' = basis_reduction_add_row_main(2,3,5)[OF Linvw i j refl] + note step' = step'(1)[OF Linv] step'(2-) show ?case proof (cases "?c = 0") case True note inv = LLL_invD[OF Linv] from inv(5)[OF i] inv(5)[of j] i j have id: "fs[i := fs ! i - 0 \\<^sub>v fs ! j] = fs" by (intro nth_equalityI, insert inv i, auto) show ?thesis by (rule Suc(1), insert step step' id True Suc(2-), auto) next case False show ?thesis using Suc(1)[OF step(1) step'(2) step(2)] Suc(2-) False step'(3) by auto qed qed lemma basis_reduction_add_rows_bound: assumes binv: "LLL_bound_invariant True upw i fs" and res: "basis_reduction_add_rows upw i fs = fs'" and i: "i < m" shows "LLL_bound_invariant True False i fs'" proof - note def = basis_reduction_add_rows_def show ?thesis proof (cases upw) case False with res binv show ?thesis by (simp add: def) next case True with binv have binv: "LLL_bound_invariant True True i fs" by auto note start = basis_reduction_add_rows_enter_bound[OF this i] from res[unfolded def] True have "basis_reduction_add_rows_loop i fs i = fs'" by auto from basis_reduction_add_rows_loop_bound[OF start(1) \_small_row_refl start(2) this i le_refl] show ?thesis by auto qed qed - -lemma basis_reduction_swap_bound: assumes - binv: "LLL_bound_invariant True False i fs" - and res: "basis_reduction_swap i fs = (upw',i',fs')" +lemma g_bnd_swap: + assumes i: "i < m" "i \ 0" + and Linv: "LLL_invariant_weak fs" + and mu_F1_i: "\\ fs i (i-1)\ \ 1 / 2" and cond: "sq_norm (gso fs (i - 1)) > \ * sq_norm (gso fs i)" - and i: "i < m" "i \ 0" -shows "LLL_bound_invariant True upw' i' fs'" -proof (rule bound_invI) - note Linv = bound_invD(1)[OF binv] - from basis_reduction_swap[OF Linv res cond i] - show Linv': "LLL_invariant upw' i' fs'" by auto - from res[unfolded basis_reduction_swap_def] - have id: "i' = i - 1" "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" by auto - from LLL_invD(6)[OF Linv] i + and fs'_def: "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" + and g_bnd: "g_bnd B fs" +shows "g_bnd B fs'" +proof - + note inv = LLL_inv_wD[OF Linv] have choice: "fs' ! k = fs ! k \ fs' ! k = fs ! i \ fs' ! k = fs ! (i - 1)" for k - unfolding id by (cases "k = i"; cases "k = i - 1", auto) - from bound_invD(2)[OF binv] i - show "f_bound True i' fs'" unfolding id(1) f_bound_def - proof (intro allI impI, goal_cases) - case (1 k) - thus ?case using choice[of k] by auto - qed + unfolding fs'_def using i inv(6) by (cases "k = i"; cases "k = i - 1", auto) let ?g1 = "\ i. gso fs i" let ?g2 = "\ i. gso fs' i" let ?n1 = "\ i. sq_norm (?g1 i)" let ?n2 = "\ i. sq_norm (?g2 i)" - from bound_invD(3)[OF binv, unfolded g_bound_def] - have short: "\ k. k < m \ ?n1 k \ of_nat N" by auto + from g_bnd[unfolded g_bnd_def] have short: "\ k. k < m \ ?n1 k \ B" by auto from short[of "i - 1"] i - have short_im1: "?n1 (i - 1) \ of_nat N" by auto - note swap = basis_reduction_swap_main[OF Linv i cond id(2)] - note updates = swap(3,4) + have short_im1: "?n1 (i - 1) \ B" by auto + note swap = basis_reduction_swap_main[OF Linv disjI2[OF mu_F1_i] i cond fs'_def] + note updates = swap(4,5) note Linv' = swap(1) - note inv' = LLL_invD[OF Linv'] - note inv = LLL_invD[OF Linv] + note inv' = LLL_inv_wD[OF Linv'] + note inv = LLL_inv_wD[OF Linv] interpret gs1: gram_schmidt_fs_int n "RAT fs" by (standard) (use inv gs.lin_indpt_list_def in \auto simp add: vec_hom_Ints\) interpret gs2: gram_schmidt_fs_int n "RAT fs'" by (standard) (use inv' gs.lin_indpt_list_def in \auto simp add: vec_hom_Ints\) let ?mu1 = "\ fs" let ?mu2 = "\ fs'" let ?mu = "?mu1 i (i - 1)" - from LLL_invD[OF Linv] have "\_small fs i" by blast - from this[unfolded \_small_def] i have mu: "abs ?mu \ 1/2" by auto + have mu: "abs ?mu \ 1/2" using mu_F1_i . have "?n2 (i - 1) = ?n1 i + ?mu * ?mu * ?n1 (i - 1)" by (subst updates(2), insert i, auto) also have "\ = inverse \ * (\ * ?n1 i) + (?mu * ?mu) * ?n1 (i - 1)" using \ by auto also have "\ \ inverse \ * ?n1 (i - 1) + (abs ?mu * abs ?mu) * ?n1 (i - 1)" by (rule add_mono[OF mult_left_mono], insert cond \, auto) also have "\ = (inverse \ + abs ?mu * abs ?mu) * ?n1 (i - 1)" by (auto simp: field_simps) also have "\ \ (inverse \ + (1/2) * (1/2)) * ?n1 (i - 1)" by (rule mult_right_mono[OF add_left_mono[OF mult_mono]], insert mu, auto) also have "inverse \ + (1/2) * (1/2) = reduction" unfolding reduction_def using \0 by (auto simp: field_simps) also have "\ * ?n1 (i - 1) \ 1 * ?n1 (i - 1)" by (rule mult_right_mono, auto simp: reduction) finally have n2im1: "?n2 (i - 1) \ ?n1 (i - 1)" by simp - show "g_bound fs'" unfolding g_bound_def + show "g_bnd B fs'" unfolding g_bnd_def proof (intro allI impI) fix k assume km: "k < m" consider (ki) "k = i" | (im1) "k = i - 1" | (other) "k \ i" "k \ i-1" by blast - thus "?n2 k \ of_nat N" + thus "?n2 k \ B" proof cases case other - from short[OF km] have "?n1 k \ of_nat N" by auto + from short[OF km] have "?n1 k \ B" by auto also have "?n1 k = ?n2 k" using km other by (subst updates(2), auto) finally show ?thesis by simp next case im1 have "?n2 k = ?n2 (i - 1)" unfolding im1 .. also have "\ \ ?n1 (i - 1)" by fact - also have "\ \ of_nat N" using short_im1 by auto + also have "\ \ B" using short_im1 by auto finally show ?thesis by simp next case ki have "?n2 k = ?n2 i" unfolding ki using i by auto also have "\ \ ?n1 (i - 1)" proof - let ?f1 = "\ i. RAT fs ! i" let ?f2 = "\ i. RAT fs' ! i" define u where "u = gs.sumlist (map (\j. ?mu1 (i - 1) j \\<^sub>v ?g1 j) [0.. {?f1 i}" have g2i: "?g2 i \ Rn" using i inv' by simp have U: "U \ Rn" unfolding U_def using inv i by auto have uU: "u \ gs.span U" proof - have im1: "i - 1 \ m" using i by auto have G1: "?g1 ` {0..< i - 1} \ Rn" using inv(5) i by auto have "u \ gs.span (?g1 ` {0 ..< i - 1})" unfolding u_def by (rule gs.sumlist_in_span[OF G1], unfold set_map, insert G1, auto intro!: gs.smult_in_span intro: gs.span_mem) also have "gs.span (?g1 ` {0 ..< i - 1}) = gs.span (?f1 ` {0 ..< i - 1})" apply(subst gs1.partial_span, insert im1 inv, unfold gs.lin_indpt_list_def) apply(blast) apply(rule arg_cong[of _ _ gs.span]) apply(subst nth_image[symmetric]) by (insert i inv, auto) also have "\ \ gs.span U" unfolding U_def by (rule gs.span_is_monotone, auto) finally show ?thesis . qed from i have im1: "i - 1 < m" by auto have u: "u \ Rn" using uU U by simp have id_u: "u + (?g1 (i - 1) - ?g2 i) = u + ?g1 (i - 1) - ?g2 i" using u g2i inv(5)[OF im1] by auto have list_id: "[0...simps intro!: inv(5)) also have "gs.span (gs2.gso ` {0 ..< i}) = gs.span (set (take i (RAT fs')))" - using inv' \i \ m\ unfolding gs.lin_indpt_list_def + using inv' \i < m\ unfolding gs.lin_indpt_list_def by (subst gs2.partial_span) auto also have "set (take i (RAT fs')) = ?f2 ` {0 ..< i}" using inv'(6) i by (subst nth_image[symmetric], auto) also have "{0 ..< i} = {0 ..< i - 1} \ {(i - 1)}" using i by auto also have "?f2 ` \ = ?f2 ` {0 ..< i - 1} \ {?f2 (i - 1)}" by auto - also have "\ = U" unfolding U_def id(2) + also have "\ = U" unfolding U_def fs'_def by (rule arg_cong2[of _ _ _ _ "(\)"], insert i inv(6), force+) finally have "gs.is_oc_projection (?g2 i) (gs.span U) (u + ?g1 (i - 1))" . hence proj: "gs.is_oc_projection (?g2 i) (gs.span U) (?g1 (i - 1))" unfolding gs.is_oc_projection_def using gs.span_add[OF U uU, of "?g1 (i - 1) - ?g2 i"] inv(5)[OF im1] g2i u id_u by (auto simp: U) from gs.is_oc_projection_sq_norm[OF this gs.span_is_subset2[OF U] inv(5)[OF im1]] show "?n2 i \ ?n1 (i - 1)" . qed - also have "\ \ of_nat N" by fact + also have "\ \ B" by fact finally show ?thesis . qed qed qed + +lemma basis_reduction_swap_bound: assumes + binv: "LLL_bound_invariant True False i fs" + and res: "basis_reduction_swap i fs = (upw',i',fs')" + and cond: "sq_norm (gso fs (i - 1)) > \ * sq_norm (gso fs i)" + and i: "i < m" "i \ 0" +shows "LLL_bound_invariant True upw' i' fs'" +proof (rule bound_invI) + note Linv = bound_invD(1)[OF binv] + from basis_reduction_swap[OF Linv res cond i] + show Linv': "LLL_invariant upw' i' fs'" by auto + from res[unfolded basis_reduction_swap_def] + have id: "i' = i - 1" "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" by auto + from LLL_invD(6)[OF Linv] i + have choice: "fs' ! k = fs ! k \ fs' ! k = fs ! i \ fs' ! k = fs ! (i - 1)" for k + unfolding id by (cases "k = i"; cases "k = i - 1", auto) + from bound_invD(2)[OF binv] i + show "f_bound True i' fs'" unfolding id(1) f_bound_def + proof (intro allI impI, goal_cases) + case (1 k) + thus ?case using choice[of k] by auto + qed + + from bound_invD(3)[OF binv, unfolded g_bound_def] + have gbnd: "g_bnd (of_nat N) fs" unfolding g_bnd_def . + from LLL_invD(11)[OF Linv, unfolded \_small_def] i + have "abs (\ fs i (i - 1)) \ 1/2" by auto + from g_bnd_swap[OF i LLL_inv_imp_w[OF Linv] this cond id(2) gbnd] + have "g_bnd (rat_of_nat N) fs'" . + thus "g_bound fs'" unfolding g_bnd_def g_bound_def . +qed + lemma basis_reduction_step_bound: assumes binv: "LLL_bound_invariant True upw i fs" and res: "basis_reduction_step upw i fs = (upw',i',fs')" and i: "i < m" shows "LLL_bound_invariant True upw' i' fs'" proof - note def = basis_reduction_step_def obtain fs'' where fs'': "basis_reduction_add_rows upw i fs = fs''" by auto show ?thesis proof (cases "i = 0") case True from increase_i_bound[OF binv i True] res True show ?thesis by (auto simp: def) next case False hence id: "(i = 0) = False" by auto note res = res[unfolded def id if_False fs'' Let_def] let ?x = "sq_norm (gso fs'' (i - 1))" let ?y = "\ * sq_norm (gso fs'' i)" from basis_reduction_add_rows_bound[OF binv fs'' i] have binv: "LLL_bound_invariant True False i fs''" by auto show ?thesis proof (cases "?x \ ?y") case True from increase_i_bound[OF binv i _ True] True res show ?thesis by auto next case gt: False hence "?x > ?y" by auto from basis_reduction_swap_bound[OF binv _ this i False] gt res show ?thesis by auto qed qed qed lemma basis_reduction_main_bound: assumes "LLL_bound_invariant True upw i fs" and res: "basis_reduction_main (upw,i,fs) = fs'" shows "LLL_bound_invariant True True m fs'" using assms proof (induct "LLL_measure i fs" arbitrary: i fs upw rule: less_induct) case (less i fs upw) have id: "LLL_bound_invariant True upw i fs = True" using less by auto note res = less(3)[unfolded basis_reduction_main.simps[of upw i fs] id] note inv = less(2) note IH = less(1) note Linv = bound_invD(1)[OF inv] show ?case proof (cases "i < m") case i: True obtain i' fs' upw' where step: "basis_reduction_step upw i fs = (upw',i',fs')" (is "?step = _") by (cases ?step, auto) note decrease = basis_reduction_step(2)[OF Linv step i] from IH[OF decrease basis_reduction_step_bound(1)[OF inv step i]] res[unfolded step] i Linv show ?thesis by auto next case False with LLL_invD[OF Linv] have i: "i = m" by auto with False res inv have "LLL_bound_invariant True upw m fs'" by auto thus ?thesis by (auto simp: LLL_invariant_def LLL_bound_invariant_def) qed qed lemma LLL_inv_initial_state_bound: "LLL_bound_invariant True True 0 fs_init" proof (intro bound_invI[OF LLL_inv_initial_state _ g_bound_fs_init]) { fix i assume i: "i < m" let ?N = "map (nat o sq_norm) fs_init" let ?r = rat_of_int from i have mem: "nat (sq_norm (fs_init ! i)) \ set ?N" using fs_init len unfolding set_conv_nth by force from mem_set_imp_le_max_list[OF _ mem] have FN: "nat (sq_norm (fs_init ! i)) \ N" unfolding N_def by force hence "\fs_init ! i\\<^sup>2 \ int N" using i by auto also have "\ \ int (N * m)" using i by fastforce finally have f_bnd: "\fs_init ! i\\<^sup>2 \ int (N * m)" . } thus "f_bound True 0 fs_init" unfolding f_bound_def by auto qed lemma reduce_basis_bound: assumes res: "reduce_basis = fs" shows "LLL_bound_invariant True True m fs" using basis_reduction_main_bound[OF LLL_inv_initial_state_bound res[unfolded reduce_basis_def]] . subsubsection \Bound extracted from @{term LLL_bound_invariant}.\ fun f_bnd :: "bool \ nat" where "f_bnd False = 2 ^ (m - 1) * N ^ m * m" | "f_bnd True = N * m" lemma f_bnd_mono: "f_bnd outside \ f_bnd False" proof (cases outside) case out: True show ?thesis proof (cases "N = 0 \ m = 0") case True thus ?thesis using out by auto next case False hence 0: "N > 0" "m > 0" by auto let ?num = "(2 ^ (m - 1) * N ^ m)" have "(N * m) * 1 \ (N * m) * (2 ^ (m - 1) * N ^ (m - 1))" by (rule mult_left_mono, insert 0, auto) also have "\ = 2 ^ (m - 1) * N ^ (Suc (m - 1)) * m " by simp also have "Suc (m - 1) = m" using 0 by simp finally show ?thesis using out by auto qed qed auto lemma aux_bnd_mono: "N * m \ (4 ^ (m - 1) * N ^ m * m * m)" proof (cases "N = 0 \ m = 0") case False hence 0: "N > 0" "m > 0" by auto let ?num = "(4 ^ (m - 1) * N ^ m * m * m)" have "(N * m) * 1 \ (N * m) * (4 ^ (m - 1) * N ^ (m - 1) * m)" by (rule mult_left_mono, insert 0, auto) also have "\ = 4 ^ (m - 1) * N ^ (Suc (m - 1)) * m * m" by simp also have "Suc (m - 1) = m" using 0 by simp finally show "N * m \ ?num" by simp qed auto context fixes outside upw k fs assumes binv: "LLL_bound_invariant outside upw k fs" begin lemma LLL_f_bnd: assumes i: "i < m" and j: "j < n" shows "\fs ! i $ j\ \ f_bnd outside" proof - from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and fbnd: "f_bound outside k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd] i have N0: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd] i have N0: "N > 0" by auto note inv = LLL_invD[OF inv] from inv i have fsi: "fs ! i \ carrier_vec n" by auto have one: "\fs ! i $ j\^1 \ \fs ! i $ j\^2" by (cases "fs ! i $ j \ 0", intro pow_mono_exp, auto) let ?num = "(4 ^ (m - 1) * N ^ m * m * m)" let ?sq_bnd = "if i \ k \ outside then int (N * m) else int ?num" have "\fs ! i $ j\^2 \ \fs ! i\\<^sup>2" using fsi j by (metis vec_le_sq_norm) also have "\ \ ?sq_bnd" using fbnd[unfolded f_bound_def, rule_format, OF i] by auto finally have two: "(fs ! i $ j)^2 \ ?sq_bnd" by simp show ?thesis proof (cases outside) case True with one two show ?thesis by auto next case False let ?num2 = "(2 ^ (m - 1) * N ^ m * m)" have four: "(4 :: nat) = 2^2" by auto have "(fs ! i $ j)^2 \ int (max (N * m) ?num)" by (rule order.trans[OF two], auto simp: of_nat_mult[symmetric] simp del: of_nat_mult) also have "max (N * m) ?num = ?num" using aux_bnd_mono by presburger also have "int ?num = int ?num * 1" by simp also have "\ \ int ?num * N ^ m" by (rule mult_left_mono, insert N0, auto) also have "\ = int (?num * N ^ m)" by simp also have "?num * N ^ m = ?num2^2" unfolding power2_eq_square four power_mult_distrib by simp also have "int \ = (int ?num2)^2" by simp finally have "(fs ! i $ j)\<^sup>2 \ (int (f_bnd outside))\<^sup>2" using False by simp thus ?thesis unfolding abs_le_square_iff[symmetric] by simp qed qed lemma LLL_gso_bound: assumes i: "i < m" and j: "j < n" and quot: "quotient_of (gso fs i $ j) = (num, denom)" shows "\num\ \ N ^ m" and "\denom\ \ N ^ m" proof - from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and gbnd: "g_bound fs" by auto + note invw = LLL_inv_imp_w[OF inv] note * = LLL_invD[OF inv] - interpret fs: fs_int' n m fs_init \ upw k fs - by standard (use inv in auto) - note d_approx[OF inv gbnd i, unfolded d_def] + interpret fs: fs_int' n m fs_init fs + by standard (use invw in auto) + note d_approx[OF invw gbnd i, unfolded d_def] let ?r = "rat_of_int" have int: "(gs.Gramian_determinant (RAT fs) i \\<^sub>v (gso fs i)) $ j \ \" proof - have "of_int_hom.vec_hom (fs ! j) $ i \ \" if "i < n" "j < m" for i j using that assms * by (intro vec_hom_Ints) (auto) then show ?thesis using * gs.gso_connect snd_gram_schmidt_int assms unfolding gs.lin_indpt_list_def by (intro fs.gs.d_gso_Ints) (auto) qed have gsi: "gso fs i \ Rn" using *(5)[OF i] . have gs_sq: "\(gso fs i $ j)\\<^sup>2 \ rat_of_nat N" by(rule order_trans, rule vec_le_sq_norm[of _ n]) (use gsi assms gbnd * LLL.g_bound_def in auto) from i have "m * m \ 0" by auto then have N0: "N \ 0" - using less_le_trans[OF LLL_D_pos[OF inv] D_approx[OF inv gbnd]] by auto + using less_le_trans[OF LLL_D_pos[OF invw] D_approx[OF invw gbnd]] by auto have "\(gso fs i $ j)\ \ max 1 \(gso fs i $ j)\" by simp also have "\ \ (max 1 \gso fs i $ j\)\<^sup>2" by (rule self_le_power, auto) also have "\ \ of_nat N" using gs_sq N0 unfolding max_def by auto finally have gs_bound: "\(gso fs i $ j)\ \ of_nat N" . have "gs.Gramian_determinant (RAT fs) i = rat_of_int (gs.Gramian_determinant fs i)" using assms *(4-6) carrier_vecD nth_mem by (intro fs.of_int_Gramian_determinant) (simp, blast) with int have "(of_int (d fs i) \\<^sub>v gso fs i) $ j \ \" unfolding d_def by simp also have "(of_int (d fs i) \\<^sub>v gso fs i) $ j = of_int (d fs i) * (gso fs i $ j)" using gsi i j by auto finally have l: "of_int (d fs i) * gso fs i $ j \ \" by auto have num: "rat_of_int \num\ \ of_int (d fs i * int N)" and denom: "denom \ d fs i" - using quotient_of_bounds[OF quot l LLL_d_pos[OF inv] gs_bound] i by auto + using quotient_of_bounds[OF quot l LLL_d_pos[OF invw] gs_bound] i by auto from num have num: "\num\ \ d fs i * int N" by linarith - from d_approx[OF inv gbnd i] have d: "d fs i \ int (N ^ i)" + from d_approx[OF invw gbnd i] have d: "d fs i \ int (N ^ i)" by linarith from denom d have denom: "denom \ int (N ^ i)" by auto note num also have "d fs i * int N \ int (N ^ i) * int N" by (rule mult_right_mono[OF d], auto) also have "\ = int (N ^ (Suc i))" by simp finally have num: "\num\ \ int (N ^ (i + 1))" by auto { fix jj assume "jj \ i + 1" with i have "jj \ m" by auto from pow_mono_exp[OF _ this, of N] N0 have "N^jj \ N^m" by auto hence "int (N^jj) \ int (N^m)" by linarith } note j_m = this have "\denom\ = denom" using quotient_of_denom_pos[OF quot] by auto also have "\ \ int (N ^ i)" by fact also have "\ \ int (N ^ m)" by (rule j_m, auto) finally show "\denom\ \ int (N ^ m)" by auto show "\num\ \ int (N ^ m)" using j_m[of "i+1"] num by auto qed lemma LLL_f_bound: assumes i: "i < m" and j: "j < n" shows "\fs ! i $ j\ \ N ^ m * 2 ^ (m - 1) * m" proof - have "\fs ! i $ j\ \ int (f_bnd outside)" using LLL_f_bnd[OF i j] by auto also have "\ \ int (f_bnd False)" using f_bnd_mono[of outside] by presburger also have "\ = int (N ^ m * 2 ^ (m - 1) * m)" by simp finally show ?thesis . qed lemma LLL_d_bound: assumes i: "i \ m" shows "abs (d fs i) \ N ^ i \ abs (d fs i) \ N ^ m" proof (cases "m = 0") case True with i have id: "m = 0" "i = 0" by auto show ?thesis unfolding id(2) using id unfolding gs.Gramian_determinant_0 d_def by auto next case m: False from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd] m have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd] m have N: "N > 0" by auto let ?r = rat_of_int - from d_approx_main[OF inv gbnd i m] + from d_approx_main[OF invw gbnd i m] have "rat_of_int (d fs i) \ of_nat (N ^ i)" by auto hence one: "d fs i \ N ^ i" by linarith also have "\ \ N ^ m" unfolding of_nat_le_iff by (rule pow_mono_exp, insert N i, auto) finally have "d fs i \ N ^ m" by simp - with LLL_d_pos[OF inv i] one + with LLL_d_pos[OF invw i] one show ?thesis by auto qed lemma LLL_mu_abs_bound: assumes i: "i < m" and j: "j < i" shows "\\ fs i j\ \ rat_of_nat (N ^ (m - 1) * 2 ^ (m - 1) * m)" proof - from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and fbnd: "f_bound outside k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd] i have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto note * = LLL_invD[OF inv] - interpret fs: fs_int' n m fs_init \ upw k fs - by standard (use inv in auto) + interpret fs: fs_int' n m fs_init fs + by standard (use invw in auto) let ?mu = "\ fs i j" from j i have jm: "j < m" by auto - from d_approx[OF inv gbnd jm] + from d_approx[OF invw gbnd jm] have dj: "d fs j \ int (N ^ j)" by linarith let ?num = "4 ^ (m - 1) * N ^ m * m * m" let ?bnd = "N^(m - 1) * 2 ^ (m - 1) * m" from fbnd[unfolded f_bound_def, rule_format, OF i] aux_bnd_mono[folded of_nat_le_iff[where ?'a = int]] have sq_f_bnd: "sq_norm (fs ! i) \ int ?num" by (auto split: if_splits) have four: "(4 :: nat) = 2^2" by auto have "?mu^2 \ (gs.Gramian_determinant (RAT fs) j) * sq_norm (RAT fs ! i)" proof - have 1: "of_int_hom.vec_hom (fs ! j) $ i \ \" if "i < n" "j < length fs" for j i using * that by (metis vec_hom_Ints) then show ?thesis by (intro fs.gs.mu_bound_Gramian_determinant[OF j], insert * j i, auto simp: set_conv_nth gs.lin_indpt_list_def) qed also have "sq_norm (RAT fs ! i) = of_int (sq_norm (fs ! i))" unfolding sq_norm_of_int[symmetric] using *(6) i by auto also have "(gs.Gramian_determinant (RAT fs) j) = of_int (d fs j)" unfolding d_def by (rule fs.of_int_Gramian_determinant, insert i j *(3,6), auto simp: set_conv_nth) also have "\ * of_int (sq_norm (fs ! i)) = of_int (d fs j * sq_norm (fs ! i))" by simp also have "\ \ of_int (int (N^j) * int ?num)" unfolding of_int_le_iff by (rule mult_mono[OF dj sq_f_bnd], auto) also have "\ = of_nat (N^(j + m) * (4 ^ (m - 1) * m * m))" by (simp add: power_add) also have "\ \ of_nat (N^( (m - 1) + (m-1)) * (4 ^ (m - 1) * m * m))" unfolding of_nat_le_iff by (rule mult_right_mono[OF pow_mono_exp], insert N j i jm, auto) also have "\ = of_nat (?bnd^2)" unfolding four power_mult_distrib power2_eq_square of_nat_mult by (simp add: power_add) finally have "?mu^2 \ (of_nat ?bnd)^2" by auto from this[folded abs_le_square_iff] show "abs ?mu \ of_nat ?bnd" by auto qed lemma LLL_d\_bound: assumes i: "i < m" and j: "j < i" shows "abs (d\ fs i j) \ N ^ (2 * (m - 1)) * 2 ^ (m - 1) * m" proof - from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and fbnd: "f_bound outside k fs" and gbnd: "g_bound fs" by auto - interpret fs: fs_int' n m fs_init \ upw k fs - by standard (use inv in auto) - from LLL_inv_N_pos[OF inv gbnd] i have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + interpret fs: fs_int' n m fs_init fs + by standard (use invw in auto) + from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto from j i have jm: "j < m - 1" "j < m" by auto let ?r = rat_of_int from LLL_d_bound[of "Suc j"] jm have "abs (d fs (Suc j)) \ N ^ Suc j" by linarith also have "\ \ N ^ (m - 1)" unfolding of_nat_le_iff by (rule pow_mono_exp, insert N jm, auto) finally have dsj: "abs (d fs (Suc j)) \ int N ^ (m - 1)" by auto from fs.d\[of j i] j i LLL_invD[OF inv] have "?r (abs (d\ fs i j)) = abs (?r (d fs (Suc j)) * \ fs i j)" unfolding d_def fs.d_def d\_def fs.d\_def by auto also have "\ = ?r (abs (d fs (Suc j))) * abs (\ fs i j)" by (simp add: abs_mult) also have "\ \ ?r (int N ^ (m - 1)) * rat_of_nat (N ^ (m - 1) * 2 ^ (m - 1) * m)" by (rule mult_mono[OF _ LLL_mu_abs_bound[OF i j]], insert dsj, linarith, auto) also have "\ = ?r (int (N ^ ((m - 1) + (m - 1)) * 2 ^ (m - 1) * m))" by (simp add: power_add) also have "(m - 1) + (m - 1) = 2 * (m - 1)" by simp finally show "abs (d\ fs i j) \ N ^ (2 * (m - 1)) * 2 ^ (m - 1) * m" by linarith qed lemma LLL_mu_num_denom_bound: assumes i: "i < m" and quot: "quotient_of (\ fs i j) = (num, denom)" shows "\num\ \ N ^ (2 * m) * 2 ^ m * m" and "\denom\ \ N ^ m" proof (atomize(full)) from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and fbnd: "f_bound outside k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd] i have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto note * = LLL_invD[OF inv] - interpret fs: fs_int' n m fs_init \ upw k fs - by standard (use inv in auto) + interpret fs: fs_int' n m fs_init fs + by standard (use invw in auto) let ?mu = "\ fs i j" let ?bnd = "N^(m - 1) * 2 ^ (m - 1) * m" show "\num\ \ N ^ (2 * m) * 2 ^ m * m \ \denom\ \ N ^ m" proof (cases "j < i") case j: True with i have jm: "j < m" by auto - from LLL_d_pos[OF inv, of "Suc j"] i j have dsj: "0 < d fs (Suc j)" by auto + from LLL_d_pos[OF invw, of "Suc j"] i j have dsj: "0 < d fs (Suc j)" by auto from quotient_of_square[OF quot] have quot_sq: "quotient_of (?mu^2) = (num * num, denom * denom)" unfolding power2_eq_square by auto from LLL_mu_abs_bound[OF assms(1) j] have mu_bound: "abs ?mu \ of_nat ?bnd" by auto have "gs.Gramian_determinant (RAT fs) (Suc j) * ?mu \ \" by (rule fs.gs.d_mu_Ints, insert j *(1,3-6) i, auto simp: set_conv_nth gs.lin_indpt_list_def vec_hom_Ints) also have "(gs.Gramian_determinant (RAT fs) (Suc j)) = of_int (d fs (Suc j))" unfolding d_def by (rule fs.of_int_Gramian_determinant, insert i j *(3,6), auto simp: set_conv_nth) finally have ints: "of_int (d fs (Suc j)) * ?mu \ \" . from LLL_d_bound[of "Suc j"] jm have d_j: "d fs (Suc j) \ N ^ m" by auto note quot_bounds = quotient_of_bounds[OF quot ints dsj mu_bound] have "abs denom \ denom" using quotient_of_denom_pos[OF quot] by auto also have "\ \ d fs (Suc j)" by fact also have "\ \ N ^ m" by fact finally have denom: "abs denom \ N ^ m" by auto from quot_bounds(1) have "\num\ \ d fs (Suc j) * int ?bnd" unfolding of_int_le_iff[symmetric, where ?'a = rat] by simp also have "\ \ N ^ m * int ?bnd" by (rule mult_right_mono[OF d_j], auto) also have "\ = (int N ^ (m + (m - 1))) * (2 ^ (m - 1)) * int m" unfolding power_add of_nat_mult by simp also have "\ \ (int N ^ (2 * m)) * (2 ^ m) * int m" unfolding of_nat_mult by (intro mult_mono pow_mono_exp, insert N, auto) also have "\ = int (N ^ (2 * m) * 2 ^ m * m)" by simp finally have num: "\num\ \ N ^ (2 * m) * 2 ^ m * m" . from denom num show ?thesis by blast next case False hence "?mu = 0 \ ?mu = 1" unfolding fs.gs.\.simps by auto hence "quotient_of ?mu = (1,1) \ quotient_of ?mu = (0,1)" by auto from this[unfolded quot] show ?thesis using N i by (auto intro!: mult_ge_one) qed qed text \Now we have bounds on each number $(f_i)_j$, $(g_i)_j$, and $\mu_{i,j}$, i.e., for rational numbers bounds on the numerators and denominators.\ lemma logN_le_2log_Mn: assumes m: "m \ 0" "n \ 0" and N: "N > 0" shows "log 2 N \ 2 * log 2 (M * n)" proof - have "N \ nat M * nat M * n * 1" using N_le_MMn m by auto also have "\ \ nat M * nat M * n * n" by (intro mult_mono, insert m, auto) finally have NM: "N \ nat M * nat M * n * n" by simp with N have "nat M \ 0" by auto hence M: "M > 0" by simp have "log 2 N \ log 2 (M * M * n * n)" proof (subst log_le_cancel_iff) show "real N \ (M * M * int n * int n)" using NM[folded of_nat_le_iff[where ?'a = real]] M by simp qed (insert N M m, auto) also have "\ = log 2 (of_int (M * n) * of_int (M * n))" unfolding of_int_mult by (simp add: ac_simps) also have "\ = 2 * log 2 (M * n)" by (subst log_mult, insert m M, auto) finally show "log 2 N \ 2 * log 2 (M * n)" by auto qed text \We now prove a combined size-bound for all of these numbers. The bounds clearly indicate that the size of the numbers grows at most polynomial, namely the sizes are roughly bounded by ${\cal O}(m \cdot \log(M \cdot n))$ where $m$ is the number of vectors, $n$ is the dimension of the vectors, and $M$ is the maximum absolute value that occurs in the input to the LLL algorithm.\ lemma combined_size_bound: fixes number :: int assumes i: "i < m" and j: "j < n" and x: "x \ {of_int (fs ! i $ j), gso fs i $ j, \ fs i j}" and quot: "quotient_of x = (num, denom)" and number: "number \ {num, denom}" and number0: "number \ 0" shows "log 2 \number\ \ 2 * m * log 2 N + m + log 2 m" "log 2 \number\ \ 4 * m * log 2 (M * n) + m + log 2 m" proof - from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and fbnd: "f_bound outside k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd] i have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto let ?bnd = "N ^ (2 * m) * 2 ^ m * m" have "N ^ m * int 1 \ N ^ (2 * m) * (2^m * int m)" by (rule mult_mono, unfold of_nat_le_iff, rule pow_mono_exp, insert N i, auto) hence le: "int (N ^ m) \ N ^ (2 * m) * 2^m * m" by auto from x consider (xfs) "x = of_int (fs ! i $ j)" | (xgs) "x = gso fs i $ j" | (xmu) "x = \ fs i j" by auto hence num_denom_bound: "\num\ \ ?bnd \ \denom\ \ N ^ m" proof (cases) case xgs from LLL_gso_bound[OF i j quot[unfolded xgs]] le show ?thesis by auto next case xmu from LLL_mu_num_denom_bound[OF i, of j, OF quot[unfolded xmu]] show ?thesis by auto next case xfs have "\denom\ = 1" using quot[unfolded xfs] by auto also have "\ \ N ^ m" using N by auto finally have denom: "\denom\ \ N ^ m" . have "\num\ = \fs ! i $ j\" using quot[unfolded xfs] by auto also have "\ \ int (N ^ m * 2 ^ (m - 1) * m)" using LLL_f_bound[OF i j] by auto also have "\ \ ?bnd" unfolding of_nat_mult of_nat_power by (intro mult_mono pow_mono_exp, insert N, auto) finally show ?thesis using denom by auto qed from number consider (num) "number = num" | (denom) "number = denom" by auto hence number_bound: "\number\ \ ?bnd" proof (cases) case num with num_denom_bound show ?thesis by auto next case denom with num_denom_bound have "\number\ \ N ^ m" by auto with le show ?thesis by auto qed from number_bound have bnd: "of_int \number\ \ real ?bnd" by linarith have "log 2 \number\ \ log 2 ?bnd" by (subst log_le_cancel_iff, insert number0 bnd, auto) also have "\ = log 2 (N^(2 * m) * 2^m) + log 2 m" by (subst log_mult[symmetric], insert i N, auto) also have "\ = log 2 (N^(2 * m)) + log 2 (2^m) + log 2 m" by (subst log_mult[symmetric], insert i N, auto) also have "log 2 (N^(2 * m)) = log 2 (N powr (2 * m))" by (rule arg_cong[of _ _ "log 2"], subst powr_realpow, insert N, auto) also have "\ = (2 * m) * log 2 N" by (subst log_powr, insert N, auto) finally show boundN: "log 2 \number\ \ 2 * m * log 2 N + m + log 2 m" by simp also have "\ \ 2 * m * (2 * log 2 (M * n)) + m + log 2 m" by (intro add_right_mono mult_mono logN_le_2log_Mn N, insert i j N, auto) finally show "log 2 \number\ \ 4 * m * log 2 (M * n) + m + log 2 m" by simp qed text \And a combined size bound for an integer implementation which stores values $f_i$, $d_{j+1}\mu_{ij}$ and $d_i$.\ interpretation fs: fs_int_indpt n fs_init by (standard) (use lin_dep in auto) lemma fs_gs_N_N': assumes "m \ 0" shows "fs.gs.N = of_nat N" proof - have 0: "Max (sq_norm ` set fs_init) \ sq_norm ` set fs_init" using len assms by auto then have 1: " nat (Max (sq_norm ` set fs_init)) \ (nat \ sq_norm) ` set fs_init" by (auto) have [simp]: "0 \ Max (sq_norm ` set fs_init)" using 0 by force have [simp]: "sq_norm ` of_int_hom.vec_hom ` set fs_init = rat_of_int ` sq_norm ` set fs_init" by (auto simp add: sq_norm_of_int image_iff) then have [simp]: "rat_of_int (Max (sq_norm ` set fs_init)) \ rat_of_int ` sq_norm ` set fs_init" using 0 by auto have "(Missing_Lemmas.max_list (map (nat \ sq_norm) fs_init)) = Max ((nat \ sq_norm) ` set fs_init)" using assms len by (subst max_list_Max) (auto) also have "\ = nat (Max (sq_norm_vec ` set fs_init))" using assms 1 by (auto intro!: nat_mono Max_eqI) also have "int \ = Max (sq_norm_vec ` set fs_init)" by (subst int_nat_eq) (auto) also have "rat_of_int \ = Max (sq_norm ` set (map of_int_hom.vec_hom fs_init))" by (rule Max_eqI[symmetric]) (auto simp add: sq_norm_of_int) finally show ?thesis unfolding N_def fs.gs.N_def by (auto) qed lemma fs_gs_N_N: "m \ 0 \ real_of_rat fs.gs.N = real N" using fs_gs_N_N' by simp lemma combined_size_bound_gso_integer: assumes "x \ {fs.\' i j |i j. j \ i \ i < m} \ {fs.\s l i j |i j l. i < m \ j \ i \ l < j}" and m: "m \ 0" and "x \ 0" "n \ 0" shows "log 2 \real_of_int x\ \ (6 + 6 * m) * log 2 (M * n) + log 2 m + m" proof - from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd m] have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd m] have N: "N > 0" by auto have "log 2 \real_of_int x\ \ log 2 m + real (3 + 3 * m) * log 2 N" using assms len fs.combined_size_bound_integer_log by (auto simp add: fs_gs_N_N) also have "\ \ log 2 m + (3 + 3 * m) * (2 * log 2 (M * n))" using logN_le_2log_Mn assms N by (intro add_left_mono, intro mult_left_mono) (auto) also have "\ = log 2 m + (6 + 6 * m) * log 2 (M * n)" by (auto simp add: algebra_simps) finally show ?thesis by auto qed lemma combined_size_bound_integer': assumes x: "x \ {fs ! i $ j | i j. i < m \ j < n} \ {d\ fs i j | i j. j < i \ i < m} \ {d fs i | i. i \ m}" (is "x \ ?fs \ ?d\ \ ?d") and m: "m \ 0" and n: "n \ 0" shows "abs x \ N ^ (2 * m) * 2 ^ m * m" "x \ 0 \ log 2 \x\ \ 2 * m * log 2 N + m + log 2 m" (is "_ \ ?l1 \ ?b1") "x \ 0 \ log 2 \x\ \ 4 * m * log 2 (M * n) + m + log 2 m" (is "_ \ _ \ ?b2") proof - let ?bnd = "int N ^ (2 * m) * 2 ^ m * int m" from bound_invD[OF binv] have inv: "LLL_invariant upw k fs" and fbnd: "f_bound outside k fs" and gbnd: "g_bound fs" by auto - from LLL_inv_N_pos[OF inv gbnd m] have N: "N > 0" by auto + note invw = LLL_inv_imp_w[OF inv] + from LLL_inv_N_pos[OF invw gbnd m] have N: "N > 0" by auto let ?r = real_of_int from x consider (fs) "x \ ?fs" | (d\) "x \ ?d\" | (d) "x \ ?d" by auto hence "abs x \ ?bnd" proof cases case fs then obtain i j where i: "i < m" and j: "j < n" and x: "x = fs ! i $ j" by auto from LLL_f_bound[OF i j, folded x] have "\x\ \ int N ^ m * 2 ^ (m - 1) * int m" by simp also have "\ \ ?bnd" by (intro mult_mono pow_mono_exp, insert N, auto) finally show ?thesis . next case d\ then obtain i j where i: "i < m" and j: "j < i" and x: "x = d\ fs i j" by auto from LLL_d\_bound[OF i j, folded x] have "\x\ \ int N ^ (2 * (m - 1)) * 2 ^ (m - 1) * int m" by simp also have "\ \ ?bnd" by (intro mult_mono pow_mono_exp, insert N, auto) finally show ?thesis . next case d then obtain i where i: "i \ m" and x: "x = d fs i" by auto from LLL_d_bound[OF i, folded x] have "\x\ \ int N ^ m * 2 ^ 0 * 1" by simp also have "\ \ ?bnd" by (intro mult_mono pow_mono_exp, insert N m, auto) finally show ?thesis . qed thus "abs x \ N ^ (2 * m) * 2 ^ m * m" by simp hence abs: "?r (abs x) \ ?r (N ^ (2 * m) * 2 ^ m * m)" by linarith assume "x \ 0" hence x: "abs x > 0" by auto from abs have "log 2 (abs x) \ log 2 (?r (N ^ (2 * m)) * 2 ^ m * ?r m)" by (subst log_le_cancel_iff, insert x N m, auto) also have "\ = log 2 (?r N ^ (2 * m)) + m + log 2 (?r m)" using N m by (auto simp: log_mult) also have "log 2 (?r N ^ (2 * m)) = real (2 * m) * log 2 (?r N)" by (subst log_nat_power, insert N, auto) finally show "?l1 \ ?b1" by simp also have "\ \ 2 * m * (2 * log 2 (M * n)) + m + log 2 m" by (intro add_right_mono mult_left_mono logN_le_2log_Mn, insert m n N, auto) finally show "?l1 \ ?b2" by simp qed lemma combined_size_bound_integer: assumes x: "x \ {fs ! i $ j | i j. i < m \ j < n} \ {d\ fs i j | i j. j < i \ i < m} \ {d fs i | i. i \ m} \ {fs.\' i j |i j. j \ i \ i < m} \ {fs.\s l i j |i j l. i < m \ j \ i \ l < j}" (is "?x \ ?s1 \ ?s2 \ ?s3 \ ?g1 \ ?g2") and m: "m \ 0" and n: "n \ 0" and "x \ 0" and "0 < M" shows "log 2 \x\ \ (6 + 6 * m) * log 2 (M * n) + log 2 m + m" proof - show ?thesis proof (cases "?x \ ?g1 \ ?g2") case True then show ?thesis using combined_size_bound_gso_integer assms by simp next case False then have x: "x \ ?s1 \ ?s2 \ ?s3" using x by auto from combined_size_bound_integer'(3)[OF this m n \x \ 0\] have "log 2 \x\ \ 4 * m * log 2 (M * n) + m + log 2 m" by simp also have "\ \ (6 + 6 * m) * log 2 (M * n) + m + log 2 m" using assms by (intro add_right_mono, intro mult_right_mono) auto finally show ?thesis by simp qed qed end (* LLL_bound_invariant *) end (* LLL locale *) end diff --git a/thys/Ordinal_Partitions/Erdos_Milner.thy b/thys/Ordinal_Partitions/Erdos_Milner.thy new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/Erdos_Milner.thy @@ -0,0 +1,1349 @@ +theory Erdos_Milner + imports Partitions + +begin + +subsection \Erdős-Milner theorem\ + +text \P. Erdős and E. C. Milner, A Theorem in the Partition Calculus. +Canadian Math. Bull. 15:4 (1972), 501-505. +Corrigendum, Canadian Math. Bull. 17:2 (1974), 305.\ + +text \The paper defines strong types as satisfying the criteria below. + It remarks that ordinals satisfy those criteria. Here is a (too complicated) proof.\ +proposition strong_ordertype_eq: + assumes D: "D \ elts \" and "Ord \" + obtains L where "\(List.set L) = D" "\X. X \ List.set L \ indecomposable (tp X)" + and "\M. \M \ D; \X. X \ List.set L \ tp (M \ X) \ tp X\ \ tp M = tp D" +proof - + define \ where "\ \ inv_into D (ordermap D VWF)" + then have bij_\: "bij_betw \ (elts (tp D)) D" + using D bij_betw_inv_into down ordermap_bij by blast + have \_cancel_left: "\d. d \ D \ \ (ordermap D VWF d) = d" + by (metis D \_def bij_betw_inv_into_left down_raw ordermap_bij small_iff_range total_on_VWF wf_VWF) + have \_cancel_right: "\\. \ \ elts (tp D) \ ordermap D VWF (\ \) = \" + by (metis \_def f_inv_into_f ordermap_surj subsetD) + have "small D" "D \ ON" + using assms down elts_subset_ON [of \] by auto + then have \_less_iff: "\\ \. \\ \ elts (tp D); \ \ elts (tp D)\ \ \ \ < \ \ \ \ < \" + using ordermap_mono_less [of _ _ VWF D] bij_betw_apply [OF bij_\] VWF_iff_Ord_less \_cancel_right trans_VWF wf_VWF + by (metis ON_imp_Ord Ord_linear2 less_V_def order.asym) + obtain \s where "List.set \s \ ON" and "\_dec \s" and tpD_eq: "tp D = \_sum \s" + using Ord_ordertype \_nf_exists by blast \ \Cantor normal form of the ordertype\ + have ord [simp]: "Ord (\s ! k)" "Ord (\_sum (take k \s))" if "k < length \s" for k + using that \list.set \s \ ON\ + by (auto simp: dual_order.trans set_take_subset elim: ON_imp_Ord) + define E where "E \ \k. lift (\_sum (take k \s)) (\\(\s!k))" + define L where "L \ map (\k. \ ` (elts (E k))) [0..s]" + have [simp]: "length L = length \s" + by (simp add: L_def) + have in_elts_E_less: "x' < x" + if "x' \ elts (E k')" "x \ elts (E k)" "k's" for k k' x' x + \ \The ordinals have been partitioned into disjoint intervals\ + proof - + have ord\: "Ord (\ \ \s ! k')" + using that by auto + from that id_take_nth_drop [of k' "take k \s"] + obtain l where "take k \s = take k' \s @ (\s!k') # l" + by (simp add: min_def) + then show ?thesis + using that by (auto simp: E_def lift_def add.assoc dest!: OrdmemD [OF ord\] intro: less_le_trans) + qed + have elts_E: "elts (E k) \ elts (\_sum \s)" + if "k < length \s" for k + proof - + have "\ \ (\s!k) \ \_sum (drop k \s)" + by (metis that Cons_nth_drop_Suc \_sum_Cons add_le_cancel_left0) + then have "(+) (\_sum (take k \s)) ` elts (\ \ (\s!k)) \ elts (\_sum (take k \s) + \_sum (drop k \s))" + by blast + also have "\ = elts (\_sum \s)" + using \_sum_take_drop by auto + finally show ?thesis + by (simp add: lift_def E_def) + qed + have \_sum_in_tpD: "\_sum (take k \s) + \ \ elts (tp D)" + if "\ \ elts (\ \ \s!k)" "k < length \s" for \ k + using elts_E lift_def that tpD_eq by (auto simp: E_def) + have Ord_\: "Ord (\ (\_sum (take k \s) + \))" + if "\ \ elts (\ \ \s!k)" "k < length \s" for \ k + using \_sum_in_tpD \D \ ON\ bij_\ bij_betw_imp_surj_on that by fastforce + define \ where "\ \ \k. ((\y. odiff y (\_sum (take k \s))) \ ordermap D VWF)" + \ \mapping the segments of @{term D} into some power of @{term \}\ + have bij_\: "bij_betw (\ k) (\ ` elts (E k)) (elts (\ \ (\s!k)))" + if "k < length \s" for k + using that by (auto simp: bij_betw_def \_def E_def inj_on_def lift_def image_comp \_sum_in_tpD \_cancel_right that) + have \_iff: "\ k x < \ k y \ (x,y) \ VWF" + if "x \ \ ` elts (E k)" "y \ \ ` elts (E k)" "k < length \s" for k x y + using that + by (auto simp: \_def E_def lift_def \_sum_in_tpD \_cancel_right Ord_\ \_less_iff) + have tp_E_eq [simp]: "tp (\ ` elts (E k)) = \\(\s!k)" + if k: "k < length \s" for k + using ordertype_eq_iff \_iff bij_\ that + by (meson Ord_\ Ord_oexp ord(1) ordertype_VWF_eq_iff replacement small_elts) + have tp_L_eq [simp]: "tp (L!k) = \\(\s!k)" + if "k < length \s" for k + by (simp add: L_def that) + have UL_eq_D: "\ (list.set L) = D" + proof (rule antisym) + show "\ (list.set L) \ D" + by (force simp: L_def tpD_eq bij_betw_apply [OF bij_\] dest: elts_E) + show "D \ \ (list.set L)" + proof + fix \ + assume "\ \ D" + then have "ordermap D VWF \ \ elts (\_sum \s)" + by (metis \small D\ ordermap_in_ordertype tpD_eq) + then show "\ \ \ (list.set L)" + using \\ \ D\ \_cancel_left in_elts_\_sum + by (fastforce simp: L_def E_def image_iff lift_def) + qed + qed + show thesis + proof + show "indecomposable (tp X)" if "X \ list.set L" for X + using that by (auto simp: L_def indecomposable_\_power) + next + fix M + assume "M \ D" and *: "\X. X \ list.set L \ tp X \ tp (M \ X)" + show "tp M = tp D" + proof (rule antisym) + show "tp M \ tp D" + by (simp add: \M \ D\ \small D\ ordertype_VWF_mono) + define \ where "\ \ \X. inv_into (M \ X) (ordermap (M \ X) VWF)" + \ \The bijection from an @{term \}-power into the appropriate segment of @{term M}\ + have bij_\: "bij_betw (\ X) (elts (tp (M \ X))) (M \ X)" for X + unfolding \_def + by (metis (no_types) \M \ D\ \small D\ bij_betw_inv_into inf_le1 ordermap_bij subset_iff_less_eq_V total_on_VWF wf_VWF) + have Ord_\: "Ord (\ X \)" if "\ \ elts (tp (M \ X))" for \ X + using \D \ ON\ \M \ D\ bij_betw_apply [OF bij_\] that by blast + have \_cancel_right: "\\ X. \ \ elts (tp (M \ X)) \ ordermap (M \ X) VWF (\ X \) = \" + by (metis \_def f_inv_into_f ordermap_surj subsetD) + have smM: "small (M \ X)" for X + by (meson \M \ D\ \small D\ inf_le1 subset_iff_less_eq_V) + then have \_less: "\X \ \. \\ < \; \ \ elts (tp (M \ X)); \ \ elts (tp (M \ X))\ + \ \ X \ < \ X \" + using ordermap_mono_less bij_betw_apply [OF bij_\] VWF_iff_Ord_less \_cancel_right trans_VWF wf_VWF + by (metis Ord_\ Ord_linear_lt less_imp_not_less ordermap_mono_less) + have "\k < length \s. \ \ elts (E k)" if \: "\ \ elts (tp D)" for \ + proof - + obtain X where "X \ set L" and X: "\ \ \ X" + by (metis UL_eq_D \ Union_iff \_def in_mono inv_into_into ordermap_surj) + then have "\k < length \s. \ \ elts (E k) \ X = \ ` elts (E k)" + apply (clarsimp simp: L_def) + by (metis \ \_cancel_right elts_E in_mono tpD_eq) + then show ?thesis + by blast + qed + then obtain K where K: "\\. \ \ elts (tp D) \ K \ < length \s \ \ \ elts (E (K \))" + by metis \ \The index from @{term "tp D"} to the appropriate segment number\ + define \ where "\ \ \d. \ (L ! K (ordermap D VWF d)) (\ (K (ordermap D VWF d)) d)" + show "tp D \ tp M" + proof (rule ordertype_inc_le) + show "small D" "small M" + using \M \ D\ \small D\ subset_iff_less_eq_V by auto + next + fix d' d + assume xy: "d' \ D" "d \ D" and "(d',d) \ VWF" + then have "d' < d" + using ON_imp_Ord \D \ ON\ by auto + define \' where "\' \ ordermap D VWF d'" + define \ where "\ \ ordermap D VWF d" + have len': "K \' < length \s" and elts': "\' \ elts (E (K \'))" + and len: "K \ < length \s" and elts: "\ \ elts (E (K \))" + using K \d' \ D\ \d \ D\ by (auto simp: \'_def \_def \small D\ ordermap_in_ordertype) + have **: "\X w. \X \ list.set L; w \ elts (tp X)\ \ w \ elts (tp (M \ X))" + using "*" by blast + have Ord_\L: "Ord (\ (L!k) (\ k d))" if "d \ \ ` elts (E k)" "k < length \s" for k d + by (metis "**" Ord_\ \length L = length \s\ bij_\ bij_betw_imp_surj_on imageI nth_mem that tp_L_eq) + have "\' < \" + by (metis \'_def \_def \d' < d\ \small D\ \_cancel_left \_less_iff ordermap_in_ordertype xy) + then have "K \' \ K \" + using elts' elts by (meson in_elts_E_less leI len' less_asym) + then consider (less) "K \' < K \" | (equal) "K \' = K \" + by linarith + then have "\ (L ! K \') (\ (K \') d') < \ (L ! K \) (\ (K \) d)" + proof cases + case less + obtain \: "\ (L ! K \') (\ (K \') d') \ M \ L ! K \'" "\ (L ! K \) (\ (K \) d) \ M \ L ! K \" + using elts' elts len' len + unfolding \'_def \_def + by (metis "**" \length L = length \s\ \_cancel_left bij_\ bij_\ bij_betw_imp_surj_on imageI nth_mem tp_L_eq xy) + then have "ordermap D VWF (\ (L ! K \') (\ (K \') d')) \ elts (E (K \'))" "ordermap D VWF (\ (L ! K \) (\ (K \) d)) \ elts (E (K \))" + using len' len elts_E tpD_eq + by (fastforce simp: L_def \'_def \_def \_cancel_right)+ + then have "ordermap D VWF (\ (L ! K \') (\ (K \') d')) < ordermap D VWF (\ (L ! K \) (\ (K \) d))" + using in_elts_E_less len less by blast + moreover have "\ (L ! K \') (\ (K \') d') \ D" "\ (L ! K \) (\ (K \) d) \ D" + using \M \ D\ \ by auto + ultimately show ?thesis + by (metis \small D\ \_cancel_left \_less_iff ordermap_in_ordertype) + next + case equal + show ?thesis + unfolding equal + proof (rule \_less) + show "\ (K \) d' < \ (K \) d" + by (metis equal \'_def \_def \(d', d) \ VWF\ \_cancel_left \_iff elts elts' imageI len xy) + have "\ (K \) d' \ elts (tp (L ! K \))" "\ (K \) d \ elts (tp (L ! K \))" + using equal \_cancel_left \'_def elts' len' \_def elts len xy + by (force intro: bij_betw_apply [OF bij_\])+ + then show "\ (K \) d' \ elts (tp (M \ L ! K \))" "\ (K \) d \ elts (tp (M \ L ! K \))" + by (simp_all add: "**" len) + qed + qed + moreover have "Ord (\ (L ! K \') (\ (K \') d'))" + using Ord_\L \'_def \_cancel_left elts' len' xy(1) by fastforce + moreover have "Ord (\ (L ! K \) (\ (K \) d))" + using Ord_\L \_def \_cancel_left elts len xy by fastforce + ultimately show "(\ d', \ d) \ VWF" + by (simp add: \_def \'_def \_def) + next + show "\ ` D \ M" + proof (clarsimp simp: \_def) + fix d + assume "d \ D" + define \ where "\ \ ordermap D VWF d" + have len: "K \ < length \s" and elts: "\ \ elts (E (K \))" + using K \d \ D\ by (auto simp: \_def \small D\ ordermap_in_ordertype) + have "\ (K \) d \ elts (tp (L! (K \)))" + using bij_\ [OF len] \d \ D\ + apply (simp add: L_def len) + by (metis \_def \_cancel_left bij_betw_imp_surj_on elts imageI) + then have "\ (L! (K \)) (\ (K \) d) \ M \ (L! (K \))" + using smM bij_betw_imp_surj_on [OF ordermap_bij] \length L = length \s\ + unfolding \_def + by (metis (no_types) "*" inv_into_into len nth_mem vsubsetD total_on_VWF wf_VWF) + then show "\ (L ! K (ordermap D VWF d)) (\ (K (ordermap D VWF d)) d) \ M" + using \_def by blast + qed + qed auto + qed + qed (simp add: UL_eq_D) +qed + + +text \The ``remark'' of Erdős and E. C. Milner, Canad. Math. Bull. Vol. 17 (2), 1974\ + +proposition indecomposable_imp_Ex_less_sets: + assumes indec: "indecomposable \" and "\ > 1" "Ord \" and A: "tp A = \" "A \ elts (\*\)" + and "x \ A" and A1: "tp A1 = \" "A1 \ A" + obtains A2 where "tp A2 = \" "A2 \ A1" "less_sets {x} A2" +proof - + have "Ord \" + using indec indecomposable_imp_Ord by blast + have "Limit \" + by (simp add: assms indecomposable_imp_Limit) + have "small A" + by (meson A small_elts smaller_than_small) + define \ where "\ \ inv_into A (ordermap A VWF)" + then have bij_\: "bij_betw \ (elts \) A" + using A bij_betw_inv_into down ordermap_bij by blast + have bij_om: "bij_betw (ordermap A VWF) A (elts \)" + using A down ordermap_bij by blast + define \ where "\ \ ordermap A VWF x" + have \: "\ \ elts \" + unfolding \_def using A \x \ A\ down by auto + then have "Ord \" + using Ord_in_Ord \Ord \\ by blast + have "A \ ON" + by (meson Ord_mult \Ord \\ \Ord \\ A dual_order.trans elts_subset_ON) + define B where "B \ \ ` (elts (succ \))" + show thesis + proof + have "small A1" + by (meson \small A\ A1 smaller_than_small) + then have "tp (A1 - B) \ tp A1" + unfolding B_def by (auto intro!: ordertype_VWF_mono del: vsubsetI) + moreover have "tp (A1 - B) \ \" + proof - + have "\ (\ \ tp B)" + unfolding B_def + proof (subst ordertype_VWF_inc_eq) + show "elts (succ \) \ ON" + by (auto simp: \_def ordertype_VWF_inc_eq intro: Ord_in_Ord) + have "elts (succ \) \ elts \" + using Ord_trans \ \Ord \\ by auto + then show "\ ` elts (succ \) \ ON" + using \A \ ON\ bij_\ bij_betw_imp_surj_on by blast + show "\ u < \ v" + if "u \ elts (succ \)" and "v \ elts (succ \)" and "u < v" for u v + proof - + have "succ \ \ elts \" + using \ Limit_def \Limit \\ by blast + then have "u \ elts \" "v \ elts \" + using Ord_trans \Ord \\ that by blast+ + then show ?thesis + using that \Limit \\ \small A\ A bij_betwE [OF bij_\] + by (metis ON_imp_Ord Ord_linear2 \A \ ON\ \_def inv_ordermap_VWF_mono_le leD) + qed + show "\ \ \ tp (elts (succ \))" + proof (subst ordertype_eq_Ord) + show "\ \ \ succ \" + by (meson \ \Limit \\ less_eq_V_def mem_not_refl subsetD succ_in_Limit_iff) + qed (use \Ord \\ in blast) + qed auto + then show ?thesis + using indecomposable_ordertype_ge [OF indec, of A1 B] \small A1\ A1 + by (auto simp: B_def) + qed + ultimately show "tp (A1 - B) = \" + using A1 by blast + show "less_sets {x} (A1 - B)" + proof (clarsimp simp: less_sets_def B_def simp del: elts_succ) + fix y + assume "y \ A1" and y: "y \ \ ` elts (succ \)" + obtain "Ord x" "Ord y" + using \A \ ON\ \x \ A\ \y \ A1\ A1 by auto + have "y \ \ ` elts (succ \)" if "y \ elts (succ x)" + proof - + have "ordermap A VWF y \ elts (ZFC_in_HOL.succ (ordermap A VWF x))" + using A1 + by (metis insert_iff ordermap_mono subset_iff that wf_VWF OrdmemD VWF_iff_Ord_less \Ord x\ \Ord y\ \small A\ \y \ A1\ elts_succ) + then show ?thesis + using that A1 unfolding \_def + by (metis \y \ A1\ \_def bij_betw_inv_into_left bij_om imageI subsetD) + qed + then show "x < y" + by (meson Ord_linear2 Ord_mem_iff_lt Ord_succ \Ord x\ \Ord y\ y succ_le_iff) + qed + qed auto +qed + + +text \the main theorem, from which they derive the headline result\ +theorem Erdos_Milner_aux: + fixes k::nat and \::V + assumes part: "partn_lst_VWF \ [ord_of_nat k, \] 2" + and indec: "indecomposable \" and "k > 1" "Ord \" and \: "\ \ elts \1" + shows "partn_lst_VWF (\*\) [ord_of_nat (2*k), min \ (\*\)] 2" +proof (cases "\=1 \ \=0") + case True + have "Ord \" + using Ord_\1 Ord_in_Ord \ by blast + show ?thesis + proof (cases "\=0") + case True + moreover have "min \ 0 = 0" + by (simp add: min_def) + ultimately show ?thesis + by (simp add: partn_lst_triv0 [where i=1]) + next + case False + then have "\=1" + using True by blast + then obtain i where "i < Suc (Suc 0)" "[ord_of_nat k, \] ! i \ \" + using partn_lst_VWF_nontriv [OF part] by auto + then have "\ \ 1" + using \\=1\ \k > 1\ by (fastforce simp: less_Suc_eq) + then have "min \ (\*\) \ 1" + by (metis Ord_1 Ord_\ Ord_linear_le Ord_mult \Ord \\ min_def order_trans) + moreover have "elts \ \ {}" + using False by auto + ultimately show ?thesis + by (auto simp: True \Ord \\ \\\0\ \\=1\ intro!: partn_lst_triv1 [where i=1]) + qed +next + case False + then have "\ \ 1" "\ \ 0" + by auto + then have "0 \ elts \" + using Ord_\1 Ord_in_Ord \ mem_0_Ord by blast + show ?thesis + proof (cases "\=0") + case True + have \: "[ord_of_nat (2 * k), 0] ! 1 = 0" + by simp + show ?thesis + using True assms + by (force simp: partn_lst_def nsets_empty_iff simp flip: numeral_2_eq_2 dest!: less_2_cases intro: \) + next + case False + then have "\ \ \" + using indec \\ \ 1\ + by (metis Ord_\ indecomposable_is_\_power le_oexp oexp_0_right) + then have "\ > 1" + using \_gt1 dual_order.strict_trans1 by blast + show ?thesis + unfolding partn_lst_def + proof clarsimp + fix f + assume "f \ [elts (\*\)]\<^bsup>2\<^esup> \ {.. [elts (\*\)]\<^bsup>2\<^esup> \ {..<2::nat}" + by (simp add: eval_nat_numeral) + obtain ord [iff]: "Ord \" "Ord \" "Ord (\*\)" + using Ord_\1 Ord_in_Ord \ indec indecomposable_imp_Ord Ord_mult by blast + have *: False + if i [rule_format]: "\H. tp H = ord_of_nat (2*k) \ H \ elts (\*\) \ \ f ` [H]\<^bsup>2\<^esup> \ {0}" + and ii [rule_format]: "\H. tp H = \ \ H \ elts (\*\) \ \ f ` [H]\<^bsup>2\<^esup> \ {1}" + and iii [rule_format]: "\H. tp H = (\*\) \ H \ elts (\*\) \ \ f ` [H]\<^bsup>2\<^esup> \ {1}" + proof - + have Ak0: "\X \ [A]\<^bsup>k\<^esup>. f ` [X]\<^bsup>2\<^esup> \ {0}" \\remark (8) about @{term"A \ S"}\ + if A_\\: "A \ elts (\*\)" and ot: "tp A \ \" for A + proof - + let ?g = "inv_into A (ordermap A VWF)" + have "small A" + using down that by auto + then have inj_g: "inj_on ?g (elts \)" + by (meson inj_on_inv_into less_eq_V_def ordermap_surj ot subset_trans) + have Aless: "\x y. \x \ A; y \ A; x < y\ \ (x,y) \ VWF" + by (meson Ord_in_Ord VWF_iff_Ord_less \Ord(\*\)\ subsetD that(1)) + then have om_A_less: "\x y. \x \ A; y \ A; x < y\ \ ordermap A VWF x < ordermap A VWF y" + by (auto simp: \small A\ ordermap_mono_less) + have \_sub: "elts \ \ ordermap A VWF ` A" + by (metis \small A\ elts_of_set less_eq_V_def ordertype_def ot replacement) + have g_less: "?g x < ?g y" if "x < y" "x \ elts \" "y \ elts \" for x y + proof - + have "?g x \ A" "?g y \ A" + using that by (meson \_sub inv_into_into subsetD)+ + moreover have "x \ ordermap A VWF ` A" "y \ ordermap A VWF ` A" + using \_sub that by blast+ + moreover have "A \ ON" + using A_\\ elts_subset_ON \Ord(\*\)\ by blast + ultimately show ?thesis + by (metis ON_imp_Ord Ord_linear_lt f_inv_into_f less_not_sym om_A_less \x < y\) + qed + have "?g \ elts \ \ elts (\ * \)" + by (meson A_\\ Pi_I' \_sub inv_into_into subset_eq) + then have fg: "f \ (\X. ?g ` X) \ [elts \]\<^bsup>2\<^esup> \ {..<2}" + by (rule nsets_compose_image_funcset [OF f _ inj_g]) + obtain i H where "i < 2" "H \ elts \" + and ot_eq: "tp H = [k,\]!i" "(f \ (\X. ?g ` X)) ` (nsets H 2) \ {i}" + using ii partn_lst_E [OF part fg] by (auto simp: eval_nat_numeral) + then consider (0) "i=0" | (1) "i=1" + by linarith + then show ?thesis + proof cases + case 0 + then have "f ` [inv_into A (ordermap A VWF) ` H]\<^bsup>2\<^esup> \ {0}" + using ot_eq \H \ elts \\ \_sub by (auto simp: nsets_def [of _ k] inj_on_inv_into elim!: nset_image_obtains) + moreover have "finite H \ card H = k" + using 0 ot_eq \H \ elts \\ down by (simp add: finite_ordertype_eq_card) + then have "inv_into A (ordermap A VWF) ` H \ [A]\<^bsup>k\<^esup>" + using \H \ elts \\ \_sub by (auto simp: nsets_def [of _ k] card_image inj_on_inv_into inv_into_into) + ultimately show ?thesis + by blast + next + case 1 + have gH: "?g ` H \ elts (\ * \)" + by (metis A_\\ \_sub \H \ elts \\ image_subsetI inv_into_into subset_eq) + have [simp]: "tp (?g ` H) = tp H" + proof (rule ordertype_VWF_inc_eq) + show "?g ` H \ ON" + using elts_subset_ON gH ord(3) by auto + show "?g x < inv_into A (ordermap A VWF) y" if "x \ H" "y \ H" "x < y" for x y + using that \H \ elts \\ g_less by blast + qed (use \H \ elts \\ elts_subset_ON ord down in auto) + show ?thesis + using ii [of "?g ` H"] ot_eq 1 + apply (auto simp: gH elim!: nset_image_obtains) + apply (meson \H \ elts \\ inj_g bij_betw_def inj_on_subset) + done + qed + qed + define K where "K \ \i x. {y \ elts (\*\). x \ y \ f{x,y} = i}" + have small_K: "small (K i x)" for i x + by (simp add: K_def) + define KI where "KI \ \i X. (\x\X. K i x)" + have KI_disj_self: "X \ KI i X = {}" for i X + by (auto simp: KI_def K_def) + define M where "M \ \D \ x. {\::V. \ \ D \ tp (K 1 x \ \ \) \ \}" + have M_sub_D: "M D \ x \ D" for D \ x + by (auto simp: M_def) + have small_M [simp]: "small (M D \ x)" if "small D" for D \ x + by (simp add: M_def that) + have 9: "tp {x \ A. tp (M D \ x) \ tp D} \ \" (is "ordertype ?AD _ \ \") + if inD: "indecomposable (tp D)" and D: "D \ elts \" and A: "A \ elts (\*\)" and tpA: "tp A = \" + and \: "\ \ D \ {X. X \ elts (\*\) \ tp X = \}" for D A \ + \\remark (9), assuming an indecomposable order type\ + proof (rule ccontr) + define A' where "A' \ {x \ A. \ tp (M D \ x) \ tp D}" + have small [iff]: "small A" "small D" + using A D down by (auto simp: M_def) + have small_\: "small (\ \)" if "\ \ D" for \ + using that \ by (auto simp: Pi_iff subset_iff_less_eq_V) + assume not_\_le: "\ \ \ tp {x \ A. tp (M D \ x) \ tp D}" + moreover + obtain "small A" "small A'" "A' \ A" and A'_sub: "A' \ elts (\ * \)" + using A'_def A down by auto + moreover have "A' = A - ?AD" + by (force simp: A'_def) + ultimately have A'_ge: "tp A' \ \" + by (metis (no_types, lifting) dual_order.refl indec indecomposable_ordertype_eq mem_Collect_eq subsetI tpA) + obtain X where "X \ A'" "finite X" "card X = k" and fX0: "f ` [X]\<^bsup>2\<^esup> \ {0}" + using Ak0 [OF A'_sub A'_ge] by (auto simp: nsets_def [of _ k]) + then have \: "\ tp (M D \ x) \ tp D" if "x \ X" for x + using that by (auto simp: A'_def) + obtain x where "x \ X" + using \card X = k\ \k>1\ by fastforce + have "\ D \ (\ x\X. M D \ x)" + proof + assume not: "D \ (\x\X. M D \ x)" + have "\X\M D \ ` X. tp D \ tp X" + proof (rule indecomposable_ordertype_finite_ge [OF inD]) + show "M D \ ` X \ {}" + using A'_def A'_ge not not_\_le by auto + show "small (\ (M D \ ` X))" + using \finite X\ by (simp add: finite_imp_small) + qed (use \finite X\ not in auto) + then show False + by (simp add: \) + qed + then obtain \ where "\ \ D" and \: "\ \ (\ x\X. M D \ x)" + by blast + define \ where "\ \ {KI 0 X \ \ \, \x\X. K 1 x \ \ \, X \ \ \}" + have \\: "X \ elts (\*\)" "\ \ \ elts (\*\)" + using A'_sub \X \ A'\ \ \\ \ D\ by auto + then have "KI 0 X \ (\x\X. K 1 x) \ X = elts (\*\)" + using \x \ X\ f by (force simp: K_def KI_def Pi_iff less_2_cases_iff) + with \\ have \\_\: "finite \" "\ \ \ \\" + by (auto simp: \_def) + then have "\ tp (K 1 x \ \ \) \ \" if "x \ X" for x + using that \\ \ D\ \ \k > 1\ \card X = k\ by (fastforce simp: M_def) + moreover have sm_K1: "small (\x\X. K 1 x \ \ \)" + by (meson Finite_V Int_lower2 \\ \ D\ \finite X\ small_\ small_UN smaller_than_small) + ultimately have not1: "\ tp (\x\X. K 1 x \ \ \) \ \" + using \finite X\ \x \ X\ indecomposable_ordertype_finite_ge [OF indec, of "(\x. K 1 x \ \ \) ` X"] by blast + moreover have "\ tp (X \ \ \) \ \" + using \finite X\ \\ \ \\ + by (meson finite_Int mem_not_refl ordertype_VWF_\ vsubsetD) + moreover have "\ \ tp (\ \)" + using \ \\ \ D\ small_\ by fastforce+ + moreover have "small (\ \)" + using \\ \ D\ small_\ by (fastforce simp: \_def intro: smaller_than_small sm_K1) + ultimately have K0\_ge: "tp (KI 0 X \ \ \) \ \" + using indecomposable_ordertype_finite_ge [OF indec \\_\] by (auto simp: \_def) + have \\: "\ \ \ elts (\ * \)" "tp (\ \) = \" + using \\ \ D\ \ by blast+ + then obtain Y where Ysub: "Y \ KI 0 X \ \ \" and "finite Y" "card Y = k" and fY0: "f ` [Y]\<^bsup>2\<^esup> \ {0}" + using Ak0 [OF _ K0\_ge] by (auto simp: nsets_def [of _ k]) + have \: "X \ Y = {}" + using Ysub KI_disj_self by blast + then have "card (X \ Y) = 2*k" + by (simp add: \card X = k\ \card Y = k\ \finite X\ \finite Y\ card_Un_disjoint) + moreover have "X \ Y \ elts (\ * \)" + using A'_sub \X \ A'\ \\(1) \Y \ KI 0 X \ \ \\ by auto + moreover have "f ` [X \ Y]\<^bsup>2\<^esup> \ {0}" + using fX0 fY0 Ysub by (auto simp: \ nsets_disjoint_2 image_Un image_UN KI_def K_def) + ultimately show False + using i \finite X\ \finite Y\ ordertype_VWF_finite_nat by auto + qed + have IX: "tp {x \ A. tp (M D \ x) \ tp D} \ \" + if D: "D \ elts \" and A: "A \ elts (\*\)" and tpA: "tp A = \" + and \: "\ \ D \ {X. X \ elts (\*\) \ tp X = \}" for D A \ + \\remark (9) for any order type\ + proof - + obtain L where UL: "\(List.set L) \ D" + and indL: "\X. X \ List.set L \ indecomposable (tp X)" + and eqL: "\M. \M \ D; \X. X \ List.set L \ tp (M \ X) \ tp X\ \ tp M = tp D" + using ord by (metis strong_ordertype_eq D order_refl) + obtain A'' where A'': "A'' \ A" "tp A'' \ \" + and "\x X. \x \ A''; X \ List.set L\ \ tp (M D \ x \ X) \ tp X" + using UL indL + proof (induction L arbitrary: thesis) + case (Cons X L) + then obtain A'' where A'': "A'' \ A" "tp A'' \ \" and "X \ D" + and ge_X: "\x X. \x \ A''; X \ List.set L\ \ tp (M D \ x \ X) \ tp X" by auto + then have tp_A'': "tp A'' = \" + by (metis A antisym down ordertype_VWF_mono tpA) + have ge_\: "tp {x \ A''. tp (M X \ x) \ tp X} \ \" + by (rule 9) (use A A'' tp_A'' Cons.prems \D \ elts \\ \X \ D\ \ in auto) + let ?A = "{x \ A''. tp (M D \ x \ X) \ tp X}" + have M_eq: "M D \ x \ X = M X \ x" if "x \ A''" for x + using that \X \ D\ by (auto simp: M_def) + show thesis + proof (rule Cons.prems) + show "\ \ tp ?A" + using ge_\ by (simp add: M_eq cong: conj_cong) + show "tp Y \ tp (M D \ x \ Y)" if "x \ ?A" "Y \ list.set (X # L)" for x Y + using that ge_X by force + qed (use A'' in auto) + qed (use tpA in auto) + then have tp_M_ge: "tp (M D \ x) \ tp D" if "x \ A''" for x + using eqL that by (auto simp: M_def) + have "\ \ tp A''" + by (simp add: A'') + also have "\ \ tp {x \ A''. tp (M D \ x) \ tp D}" + by (metis (mono_tags, lifting) tp_M_ge eq_iff mem_Collect_eq subsetI) + also have "\ \ tp {x \ A. tp D \ tp (M D \ x)}" + by (rule ordertype_mono) (use A'' A down in auto) + finally show ?thesis . + qed + have [simp]: "tp {0} = 1" + using ordertype_eq_Ord by fastforce + have IX': "tp {x \ A'. tp (K 1 x \ A) \ \} \ \" + if A: "A \ elts (\*\)" "tp A = \" and A': "A' \ elts (\*\)" "tp A' = \" for A A' + proof - + have \: "\ \ tp (K 1 t \ A)" if "t \ A'" "1 \ tp {\. \ = 0 \ \ \ tp (K 1 t \ A)}" for t + using that + by (metis Collect_empty_eq less_eq_V_0_iff ordertype_empty zero_neq_one) + have "tp {x \ A'. 1 \ tp {\. \ = 0 \ \ \ tp (K 1 x \ A)}} + \ tp {x \ A'. \ \ tp (K 1 x \ A)}" + by (rule ordertype_mono) (use "\" A' in \auto simp: down\) + then show ?thesis + using IX [of "{0}" A' "\x. A"] that \0 \ elts \\ + by (simp add: M_def cong: conj_cong) + qed + + have 10: "\x0 \ A. \g \ elts \ \ elts \. strict_mono_on g (elts \) \ (\\ \ F. g \ = \) + \ (\\ \ elts \. tp (K 1 x0 \ \ (g \)) \ \)" + if F: "finite F" "F \ elts \" + and A: "A \ elts (\*\)" "tp A = \" + and \: "\ \ elts \ \ {X. X \ elts (\ * \) \ tp X = \}" + for F A \ + proof - + define p where "p \ card F" + have "\ \ F" + using that by auto + then obtain \ :: "nat \ V" where bij\: "bij_betw \ {..p} (insert \ F)" and mon\: "strict_mono_on \ {..p}" + using ZFC_Cardinals.ex_bij_betw_strict_mono_card [of "insert \ F"] elts_subset_ON \Ord \\ F + by (simp add: p_def lessThan_Suc_atMost) blast + have less_\_I: "\ k < \ l" if "k < l" "l \ p" for k l + using mon\ that by (auto simp: strict_mono_on_def) + then have less_\_D: "k < l" if "\ k < \ l" "k \ p" for k l + by (metis less_asym linorder_neqE_nat that) + have Ord_\: "Ord (\ k)" if "k \ p" for k + by (metis (no_types, lifting) ON_imp_Ord atMost_iff insert_subset mem_Collect_eq order_trans \F \ elts \\ bij\ bij_betwE elts_subset_ON \Ord \\ that) + have le_\0 [simp]: "\j. j \ p \ \ 0 \ \ j" + by (metis eq_refl leI le_0_eq less_\_I less_imp_le) + have le_\: "\ i \ \ (j - Suc 0)" if "i < j" "j \ p" for i j + proof (cases i) + case 0 then show ?thesis + using le_\0 that by auto + next + case (Suc i') then show ?thesis + by (metis (no_types, hide_lams) Suc_pred le_less less_Suc_eq less_Suc_eq_0_disj less_\_I not_less_eq that) + qed + + have [simp]: "\ p = \" + proof - + obtain k where k: "\ k = \" "k \ p" + by (meson atMost_iff bij\ bij_betw_iff_bijections insertI1) + then have "k = p \ k < p" + by linarith + then show ?thesis + using bij\ ord k that(2) + by (metis OrdmemD atMost_iff bij_betw_iff_bijections insert_iff leD less_\_D order_refl subsetD) + qed + + have F_imp_Ex: "\k < p. \ = \ k" if "\ \ F" for \ + proof - + obtain k where k: "k \ p" "\ = \ k" + by (metis \\ \ F\ atMost_iff bij\ bij_betw_def imageE insert_iff) + then have "k \ p" + using that F by auto + with k show ?thesis + using le_neq_implies_less by blast + qed + have F_imp_ge: "\ \ \ 0" if "\ \ F" for \ + using F_imp_Ex [OF that] by (metis dual_order.order_iff_strict le0 less_\_I) + define D where "D \ \k. (if k=0 then {..<\ 0} else {\ (k-1)<..<\ k}) \ elts \" + have D\: "D k \ elts \" for k + by (auto simp: D_def) + then have small_D [simp]: "small (D k)" for k + by (meson down) + have M_Int_D: "M (elts \) \ x \ D k = M (D k) \ x" if "k \ p" for x k + using D\ by (auto simp: M_def) + have \_le_if_D: "\ k \ \" if "\ \ D (Suc k)" for \ k + using that + by (simp add: D_def order.order_iff_strict split: if_split_asm) + have "disjnt (D i) (D j)" if "i < j" "j \ p" for i j + proof (cases j) + case (Suc j') + then show ?thesis + using that + apply (auto simp: disjnt_def D_def) + using not_less_eq by (blast intro: less_\_D less_trans Suc_leD)+ + qed (use that in auto) + then have disjnt_DD: "disjnt (D i) (D j)" if "i \ j" "i \ p" "j \ p" for i j + using disjnt_sym nat_neq_iff that by auto + have UN_D_eq: "(\l \ k. D l) = {..<\ k} \ (elts \ - F)" if "k \ p" for k + using that + proof (induction k) + case 0 + then show ?case + by (auto simp: D_def F_imp_ge leD) + next + case (Suc k) + have "D (Suc k) \ {..<\ k} \ (elts \ - F) = {..<\ (Suc k)} \ (elts \ - F)" + (is "?lhs = ?rhs") + proof + show "?lhs \ ?rhs" + using Suc.prems + by (auto simp: D_def if_split_mem2 intro: less_\_I less_trans dest!: less_\_D F_imp_Ex) + have "\x. \x < \ (Suc k); x \ elts \; x \ F; \ k \ x\ \ \ k < x" + using Suc.prems \F \ elts \\ bij\ le_imp_less_or_eq + by (fastforce simp: bij_betw_iff_bijections) + then show "?rhs \ ?lhs" + using Suc.prems by (auto simp: D_def Ord_not_less Ord_in_Ord [OF \Ord \\] Ord_\ if_split_mem2) + qed + then + show ?case + using Suc by (simp add: atMost_Suc) + qed + have \_decomp: "elts \ = F \ (\k \ p. D k)" + using \F \ elts \\ OrdmemD [OF \Ord \\] by (auto simp: UN_D_eq) + define \idx where "\idx \ \\. @k. \ \ D k \ k \ p" + have \idx: "\ \ D (\idx \) \ \idx \ \ p" if "\ \ elts \ - F" for \ + using that by (force simp: \idx_def \_decomp intro: someI_ex del: conjI) + have any_imp_\idx: "k = \idx \" if "\ \ D k" "k \ p" for k \ + proof (rule ccontr) + assume non: "k \ \idx \" + have "\ \ F" + using that UN_D_eq by auto + then show False + using disjnt_DD [OF non] by (metis D\ Diff_iff \idx disjnt_iff subsetD that) + qed + have "\A'. A' \ A \ tp A' = \ \ (\x \ A'. F \ M (elts \) \ x)" + using F + proof induction + case (insert \ F) + then obtain A' where "A' \ A" and A': "A' \ elts (\*\)" "tp A' = \" and FN: "\x. x \ A' \ F \ M (elts \) \ x" + using A(1) by auto + define A'' where "A'' \ {x \ A'. \ \ tp (K 1 x \ \ \)}" + have "\ \ elts \" "F \ elts \" + using insert by auto + note ordertype_eq_Ord [OF \Ord \\, simp] + show ?case + proof (intro exI conjI) + show "A'' \ A" + using \A' \ A\ by (auto simp: A''_def) + have "tp A'' \ \" + using \A'' \ A\ down ordertype_VWF_mono A by blast + moreover have "\ \ \ elts (\*\)" "tp (\ \) = \" + using \ \\ \ elts \\ by auto + then have "\ \ tp A''" + using IX' [OF _ _ A'] by (simp add: A''_def) + ultimately show "tp A'' = \" + by (rule antisym) + have "\ \ M (elts \) \ x" "F \ M (elts \) \ x" + if "x \ A''" for x + proof - + show "F \ M (elts \) \ x" + using A''_def FN that by blast + show "\ \ M (elts \) \ x" + using \\ \ elts \\ that by (simp add: M_def A''_def) + qed + then show "\x\A''. insert \ F \ M (elts \) \ x" + by blast + qed + qed (use A in auto) + then obtain A' where A': "A' \ A" "tp A' = \" and FN: "\x. x \ A' \ F \ M (elts \) \ x" + by metis + have False + if *: "\x0 g. \x0 \ A; g \ elts \ \ elts \; strict_mono_on g (elts \)\ + \ (\\\F. g \ \ \) \ (\\\elts \. tp (K 1 x0 \ \ (g \)) < \)" + proof - + { fix x \ \construction of the monotone map @{term g} mentioned above\ + assume "x \ A'" + with A' have "x \ A" by blast + have "\k. k \ p \ tp (M (D k) \ x) < tp (D k)" (is "?P") + proof (rule ccontr) + assume "\ ?P" + then have le: "tp (D k) \ tp (M (D k) \ x)" if "k \ p" for k + by (meson Ord_linear2 Ord_ordertype that) + have "\f\D k \ M (D k) \ x. inj_on f (D k) \ (strict_mono_on f (D k))" + if "k \ p" for k + using le [OF that] that VWF_iff_Ord_less + apply (clarsimp simp: ordertype_le_ordertype strict_mono_on_def) + by (metis (full_types) D\ M_sub_D Ord_in_Ord PiE VWF_iff_Ord_less ord(2) subsetD) + then obtain h where fun_h: "\k. k \ p \ h k \ D k \ M (D k) \ x" + and inj_h: "\k. k \ p \ inj_on (h k) (D k)" + and mono_h: "\k x y. k \ p \ strict_mono_on (h k) (D k)" + by metis + then have fun_hD: "\k. k \ p \ h k \ D k \ D k" + by (auto simp: M_def) + have h_increasing: "\ \ h k \" + if "k \ p" and \: "\ \ D k" for k \ + proof (rule Ord_mono_imp_increasing) + show "h k \ D k \ D k" + by (simp add: fun_hD that(1)) + show "D k \ ON" + using D\ elts_subset_ON ord(2) by blast + qed (auto simp: that mono_h) + define g where "g \ \\. if \ \ F then \ else h (\idx \) \" + have [simp]: "g \ = \" if "\ \ F" for \ + using that by (auto simp: g_def) + have fun_g: "g \ elts \ \ elts \" + proof (rule Pi_I) + fix x assume "x \ elts \" + then have "x \ D (\idx x)" "\idx x \ p" if "x \ F" + using that by (auto simp: \idx) + then show "g x \ elts \" + using fun_h D\ M_sub_D \x \ elts \\ + by (simp add: g_def) blast + qed + have h_in_D: "h (\idx \) \ \ D (\idx \)" if "\ \ F" "\ \ elts \" for \ + using \idx fun_hD that by fastforce + have 1: "\ k < h (\idx \) \" + if "k < p" and \: "\ \ F" "\ \ elts \" and "\ k < \" for k \ + using that h_in_D [OF \] \idx + by (fastforce simp: D_def dest: h_increasing split: if_split_asm) + moreover have 2: "h (\idx \) \ < \ k" + if \: "\ \ F" "\ \ elts \" and "k < p" "\ < \ k" for \ k + proof - + have "\idx \ \ k" + proof (rule ccontr) + assume "\ \idx \ \ k" + then have "k < \idx \" + by linarith + then show False + using \_le_if_D \idx + by (metis Diff_iff Suc_pred le0 leD le_\ le_less_trans \ \\ < \ k\) + qed + then show ?thesis + using that h_in_D [OF \] + apply (simp add: D_def split: if_split_asm) + apply (metis (no_types) dual_order.order_iff_strict le0 less_\_I less_trans) + by (metis (no_types) dual_order.order_iff_strict less_\_I less_trans) + qed + moreover have "h (\idx \) \ < h (\idx \) \" + if \: "\ \ F" "\ \ elts \" and \: "\ \ F" "\ \ elts \" and "\ < \" for \ \ + proof - + have le: "\idx \ \ \idx \" if "\ (\idx \ - Suc 0) < h (\idx \) \" "h (\idx \) \ < \ (\idx \)" + by (metis 2 that Diff_iff \idx \ \ \\ < \\ dual_order.strict_implies_order dual_order.strict_trans1 h_increasing leI le_\ less_asym) + have "h 0 \ < h 0 \" if "\idx \ = 0" "\idx \ = 0" + using that mono_h unfolding strict_mono_on_def + by (metis Diff_iff \idx \ \ \\ < \\) + moreover have "h 0 \ < h (\idx \) \" + if "0 < \idx \" "h 0 \ < \ 0" and "\ (\idx \ - Suc 0) < h (\idx \) \" + by (meson DiffI \idx \ le_\ le_less_trans less_le_not_le that) + moreover have "\idx \ \ 0" + if "0 < \idx \" "h 0 \ < \ 0" "\ (\idx \ - Suc 0) < h (\idx \) \" + using le le_0_eq that by fastforce + moreover have "h (\idx \) \ < h (\idx \) \" + if "\ (\idx \ - Suc 0) < h (\idx \) \" "h (\idx \) \ < \ (\idx \)" + "h (\idx \) \ < \ (\idx \)" "\ (\idx \ - Suc 0) < h (\idx \) \" + using mono_h unfolding strict_mono_on_def + by (metis le Diff_iff \idx \ \ \\ < \\ le_\ le_less le_less_trans that) + ultimately show ?thesis + using h_in_D [OF \] h_in_D [OF \] by (simp add: D_def split: if_split_asm) + qed + ultimately have sm_g: "strict_mono_on g (elts \)" + by (auto simp: g_def strict_mono_on_def dest!: F_imp_Ex) + show False + using * [OF \x \ A\ fun_g sm_g] + proof safe + fix \ + assume "\ \ elts \" and \: "tp (K 1 x \ \ (g \)) < \" + have FM: "F \ M (elts \) \ x" + by (meson FN \x \ A'\) + have False if "tp (K (Suc 0) x \ \ \) < \" "\ \ F" + using that FM by (auto simp: M_def) + moreover have False if "tp (K (Suc 0) x \ \ (g \)) < \" "\ \ D k" "k \ p" "\ \ F" for k + proof - + have "h (\idx \) \ \ M (D (\idx \)) \ x" + using fun_h \idx \\ \ elts \\ \\ \ F\ by auto + then show False + using that by (simp add: M_def g_def leD) + qed + ultimately show False + using \\ \ elts \\ \ by (force simp: \_decomp) + qed auto + qed + then have "\l. l \ p \ tp (M (elts \) \ x \ D l) < tp (D l)" + using M_Int_D by auto + } + then obtain l where lp: "\x. x \ A'\ l x \ p" + and lless: "\x. x \ A'\ tp (M (elts \) \ x \ D (l x)) < tp (D (l x))" + by metis + obtain A'' L where "A'' \ A'" and A'': "A'' \ elts (\ * \)" "tp A'' = \" and lL: "\x. x \ A'' \ l x = L" + proof - + have eq: "A' = (\i\p. {x \ A'. l x = i})" + using lp by auto + have "\X\(\i. {x \ A'. l x = i}) ` {..p}. \ \ tp X" + proof (rule indecomposable_ordertype_finite_ge [OF indec]) + show "small (\i\p. {x \ A'. l x = i})" + by (metis A'(1) A(1) eq down smaller_than_small) + qed (use A' eq in auto) + then show thesis + proof + fix A'' + assume A'': "A'' \ (\i. {x \ A'. l x = i}) ` {..p}" and "\ \ tp A''" + then obtain L where L: "\x. x \ A'' \ l x = L" + by auto + have "A'' \ A'" + using A'' by force + then have "tp A'' \ tp A'" + by (meson A' A down order_trans ordertype_VWF_mono) + with \\ \ tp A''\ have "tp A'' = \" + using A'(2) by auto + moreover have "A'' \ elts (\ * \)" + using A' A \A'' \ A'\ by auto + ultimately show thesis + using L that [OF \A'' \ A'\] by blast + qed + qed + have \D: "\ \ D L \ {X. X \ elts (\ * \) \ tp X = \}" + using \ D\ by blast + have "M (elts \) \ x \ D L = M (D L) \ x" for x + using D\ by (auto simp: M_def) + then have "tp (M (D L) \ x) < tp (D L)" if "x \ A''" for x + using lless that \A'' \ A'\ lL by force + then have \: "{x \ A''. tp (D L) \ tp (M (D L) \ x)} = {}" + using leD by blast + have "\ \ tp {x \ A''. tp (D L) \ tp (M (D L) \ x)}" + using IX [OF D\ A'' \D] by simp + then show False + using \\ \ 0\ by (simp add: \) + qed + then show ?thesis + by (meson Ord_linear2 Ord_ordertype \Ord \\) + qed + let ?U = "UNIV :: nat set" + define \ where "\ \ fst \ from_nat_into (elts \ \ ?U)" + define q where "q \ to_nat_on (elts \ \ ?U)" + have co_\U: "countable (elts \ \ ?U)" + by (simp add: \ less_\1_imp_countable) + moreover have "elts \ \ ?U \ {}" + using \0 \ elts \\ by blast + ultimately have "range (from_nat_into (elts \ \ ?U)) = (elts \ \ ?U)" + by (metis range_from_nat_into) + then have \_in_\ [simp]: "\ i \ elts \" for i + by (metis SigmaE \_def comp_apply fst_conv range_eqI) + + then have Ord_\ [simp]: "Ord (\ i)" for i + using Ord_in_Ord by blast + + have inf_\U: "infinite (elts \ \ ?U)" + using \0 \ elts \\ finite_cartesian_productD2 by auto + + have 11 [simp]: "\ (q (\,n)) = \" if "\ \ elts \" for \ n + by (simp add: \_def q_def that co_\U) + have range_\ [simp]: "range \ = elts \" + by (auto simp: image_iff) (metis 11) + have [simp]: "KI i {} = UNIV" "KI i (insert a X) = K i a \ KI i X" for i a X + by (auto simp: KI_def) + define \ where "\ \ \n::nat. \\ x. (\\ \ elts \. \ \ \ elts (\*\) \ tp (\ \) = \) \ x ` {.. elts (\*\) + \ (\\ \ elts \. \ \) \ KI 1 (x ` {.. strict_mono_sets (elts \) \" + define \ where "\ \ \n::nat. \g \ \' xn. g \ elts \ \ elts \ \ strict_mono_on g (elts \) \ (\i\n. g (\ i) = \ i) + \ (\\ \ elts \. \' \ \ K 1 xn \ \ (g \)) + \ less_sets {xn} (\' (\ n)) \ xn \ \ (\ n)" + let ?\0 = "\\. plus (\ * \) ` elts \" + have base: "\ 0 ?\0 x" for x + by (auto simp: \_def add_mult_less add_mult_less_add_mult ordertype_image_plus strict_mono_sets_def less_sets_def) + have step: "Ex (\(g,\',xn). \ n g \ \' xn \ \ (Suc n) \' (x(n:=xn)))" if "\ n \ x" for n \ x + proof - + have \: "\\. \ \ elts \ \ \ \ \ elts (\ * \) \ tp (\ \) = \" + and x: "x ` {.. elts (\ * \)" + and sub: "\ (\ ` elts \) \ KI (Suc 0) (x ` {..) \" + using that by (auto simp: \_def) + have \\: "\ ` {..n} \ elts \" and \sub: "\ (\ n) \ elts (\ * \)" + by (auto simp: \) + have \fun: "\ \ elts \ \ {X. X \ elts (\ * \) \ tp X = \}" + by (simp add: \) + then obtain xn g where xn: "xn \ \ (\ n)" and g: "g \ elts \ \ elts \" + and sm_g: "strict_mono_on g (elts \)" and g_\: "\\ \ \`{..n}. g \ = \" + and g_\: "\\ \ elts \. \ \ tp (K 1 xn \ \ (g \))" + using 10 [OF _ \\ \sub _ \fun] by (auto simp: \) + have tp1: "tp (K 1 xn \ \ (g \)) = \" if "\ \ elts \" for \ + proof (rule antisym) + have "tp (K 1 xn \ \ (g \)) \ tp (\ (g \))" + proof (rule ordertype_VWF_mono) + show "small (\ (g \))" + by (metis PiE \ down g that) + qed auto + also have "\ = \" + using \ g that by force + finally show "tp (K 1 xn \ \ (g \)) \ \" . + qed (use that g_\ in auto) + have tp2: "tp (\ (\ n)) = \" + by (auto simp: \) + obtain A2 where A2: "tp A2 = \" "A2 \ K 1 xn \ \ (\ n)" "less_sets {xn} A2" + using indecomposable_imp_Ex_less_sets [OF indec \\ > 1\ \Ord \\ tp2] + by (metis \sub \_in_\ atMost_iff image_eqI inf_le2 le_refl xn tp1 g_\) + then have A2_sub: "A2 \ \ (\ n)" by simp + let ?\ = "\\. if \ = \ n then A2 else K 1 xn \ \ (g \)" + have [simp]: "({.. {x. x \ n}) = ({.. (\x\elts \ \ {\. \ \ \ n}. \ (g x)) \ KI (Suc 0) (x ` {.. KI (Suc 0) (x ` {.. elts (\ * \)" + using \sub sub A2 by fastforce+ + moreover have "xn \ elts (\ * \)" + using \sub xn by blast + moreover have "strict_mono_sets (elts \) ?\" + using sm sm_g g g_\ A2_sub + unfolding strict_mono_sets_def strict_mono_on_def less_sets_def Pi_iff subset_iff Ball_def Bex_def image_iff + by (simp (no_asm_use) add: if_split_mem2) (smt order_refl) + ultimately have "\ (Suc n) ?\ (x(n := xn))" + using tp1 x A2 by (auto simp: \_def K_def) + with A2 show ?thesis + by (rule_tac x="(g,?\,xn)" in exI) (simp add: \_def g sm_g g_\ xn) + qed + define G where "G \ \n \ x. @(g,\',x'). \xn. \ n g \ \' xn \ x' = (x(n:=xn)) \ \ (Suc n) \' x'" + have G\: "(\(g,\',x'). \ (Suc n) \' x') (G n \ x)" + and G\: "(\(g,\',x'). \ n g \ \' (x' n)) (G n \ x)" if "\ n \ x" for n \ x + using step [OF that] by (force simp: G_def dest: some_eq_imp)+ + define H where "H \ rec_nat (id,?\0,undefined) (\n (g0,\,x0). G n \ x0)" + have H_Suc: "H (Suc n) = (case H n of (g0, xa, xb) \ G n xa xb)" for n + by (simp add: H_def) + have "(\(g,\,x). \ n \ x) (H n)" for n + proof (induction n) + case 0 show ?case + by (simp add: H_def base) + next + case (Suc n) then show ?case + using G\ by (fastforce simp: H_Suc) + qed + then have H_imp_\: "\ n \ x" if "H n = (g,\,x)" for g \ x n + by (metis case_prodD that) + then have H_imp_\: "(\(g,\',x'). let (g0,\,x) = H n in \ n g \ \' (x' n)) (H (Suc n))" for n + using G\ by (fastforce simp: H_Suc split: prod.split) + define g where "g \ \n. (\(g,\,x). g) (H (Suc n))" + have g: "g n \ elts \ \ elts \" and sm_g: "strict_mono_on (g n) (elts \)" + and 13: "\i. i\n \ g n (\ i) = \ i" for n + using H_imp_\ [of n] by (auto simp: g_def \_def) + define \ where "\ \ \n. (\(g,\,x). \) (H n)" + define x where "x \ \n. (\(g,\,x). x n) (H (Suc n))" + have 14: "\ (Suc n) \ \ K 1 (x n) \ \ n (g n \)" if "\ \ elts \" for \ n + using H_imp_\ [of n] that by (force simp: \_def \_def x_def g_def) + then have x14: "\ (Suc n) \ \ \ n (g n \)" if "\ \ elts \" for \ n + using that by blast + have 15: "x n \ \ n (\ n)" and 16: "less_sets {x n} (\ (Suc n) (\ n))" for n + using H_imp_\ [of n] by (force simp: \_def \_def x_def)+ + have \_\\: "\ n \ \ elts (\ * \)" if "\ \ elts \" for \ n + using H_imp_\ [of n] that by (auto simp: \_def \_def split: prod.split) + have 12: "strict_mono_sets (elts \) (\ n)" for n + using H_imp_\ [of n] that by (auto simp: \_def \_def split: prod.split) + have tp_\: "tp (\ n \) = \" if "\ \ elts \" for \ n + using H_imp_\ [of n] that by (auto simp: \_def \_def split: prod.split) + let ?Z = "range x" + have S_dec: "\ (\ (m+k) ` elts \) \ \ (\ m ` elts \)" for k m + by (induction k) (use 14 g in \fastforce+\) + have "x n \ K 1 (x m)" if "m (\\ \ elts \. \ n \)" + by (meson "15" UN_I \_in_\) + also have "\ \ (\\ \ elts \. \ (Suc m) \)" + using S_dec [of "Suc m"] less_iff_Suc_add that by auto + also have "\ \ K 1 (x m)" + using 14 by auto + finally show ?thesis . + qed + then have "f{x m, x n} = 1" if "m2\<^esup> \ {1}" + by (clarsimp simp: nsets_2_eq) (metis insert_commute less_linear) + moreover have Z_sub: "?Z \ elts (\ * \)" + using "15" \_\\ \_in_\ by blast + moreover have "tp ?Z \ \ * \" + proof - + define \ where "\ \ \i j x. wfrec (measure (\k. j-k)) (\\ k. if k (Suc k)) else x) i" + have \: "\ i j x = (if i (Suc i) j x) else x)" for i j x + by (simp add: \_def wfrec cut_apply) + have 17: "\ k j (\ i) = \ i" if "i \ k" for i j k + using wf_measure [of "\k. j-k"] that + by (induction k rule: wf_induct_rule) (simp add: "13" \ le_imp_less_Suc) + have \_in_\: "\ i j \ \ elts \" if "\ \ elts \" for i j \ + using wf_measure [of "\k. j-k"] that + proof (induction i rule: wf_induct_rule) + case (less i) + with g show ?case by (force simp: \ [of i]) + qed + then have \_fun: "\ i j \ elts \ \ elts \" for i j + by simp + have sm_\: "strict_mono_on (\ i j) (elts \)" for i j + using wf_measure [of "\k. j-k"] + proof (induction i rule: wf_induct_rule) + case (less i) + with sm_g show ?case + by (auto simp: \ [of i] strict_mono_on_def \_in_\) + qed + have *: "\ j (\ j) \ \ i (\ i j (\ j))" if "i < j" for i j + using wf_measure [of "\k. j-k"] that + proof (induction i rule: wf_induct_rule) + case (less i) + then have "j - Suc i < j - i" + by (metis (no_types) Suc_diff_Suc lessI) + with less \_in_\ show ?case + by (simp add: \ [of i]) (metis 17 Suc_lessI \_in_\ order_refl order_trans x14) + qed + have le: "\ i j (\ j) \ \ i \ \ j \ \ i" for i j + using sm_\ unfolding strict_mono_on_def + by (metis "17" Ord_in_Ord Ord_linear2 \_in_\ leD le_refl less_V_def \Ord \\) + then have less: "\ i j (\ j) < \ i \ \ j < \ i" for i j + by (metis (no_types, lifting) "17" \_in_\ less_V_def order_refl sm_\ strict_mono_on_def) + have eq: "\ i j (\ j) = \ i \ \ j = \ i" for i j + by (metis eq_refl le less less_le) + have 18: "less_sets (\ m (\ m)) (\ n (\ n)) \ \ m < \ n" for m n + proof (cases n m rule: linorder_cases) + case less + show ?thesis + proof (intro iffI) + assume "less_sets (\ m (\ m)) (\ n (\ n))" + moreover + have "\ less_sets (\ m (\ m)) (\ n (\ n))" if "\ n = \ m" + by (metis "*" "15" eq less less_V_def less_sets_def less_sets_weaken2 that) + moreover + have "\ less_sets (\ m (\ m)) (\ n (\ n))" if "\ n < \ m" + using that 12 15 * [OF less] + apply (clarsimp simp: less_sets_def strict_mono_sets_def) + by (metis Ord_in_Ord Ord_linear2 \_in_\ \_in_\ \Ord \\ le leD less_asym subsetD) + ultimately show "\ m < \ n" + by (meson Ord_in_Ord Ord_linear_lt \_in_\ \Ord \\) + next + assume "\ m < \ n" + then have "less_sets (\ n (\ n m (\ m))) (\ n (\ n))" + by (metis "12" \_in_\ \_in_\ eq le less_V_def strict_mono_sets_def) + then show "less_sets (\ m (\ m)) (\ n (\ n))" + by (meson *[OF less] less_sets_weaken1) + qed + next + case equal + with 15 show ?thesis by auto + next + case greater + show ?thesis + proof (intro iffI) + assume "less_sets (\ m (\ m)) (\ n (\ n))" + moreover + have "\ less_sets (\ m (\ m)) (\ n (\ n))" if "\ n = \ m" + by (metis "*" "15" disjnt_iff eq greater in_mono less_sets_imp_disjnt that) + moreover + have "\ less_sets (\ m (\ m)) (\ n (\ n))" if "\ n < \ m" + using that 12 15 * [OF greater] + apply (clarsimp simp: less_sets_def strict_mono_sets_def) + by (meson \_in_\ \_in_\ in_mono less less_asym) + ultimately show "\ m < \ n" + by (meson Ord_\ Ord_linear_lt) + next + assume "\ m < \ n" + then have "less_sets (\ m (\ m)) (\ m (\ m n (\ n)))" + by (meson 12 Ord_in_Ord Ord_linear2 \_in_\ \_in_\ le leD ord(2) strict_mono_sets_def) + then show "less_sets (\ m (\ m)) (\ n (\ n))" + by (meson "*" greater less_sets_weaken2) + qed + qed + have \_increasing_\: "\ n (\ n) \ \ m (\ m)" if "m \ n" "\ m = \ n" for m n + by (metis "*" "17" dual_order.order_iff_strict that) + moreover have INF: "infinite {n. n \ m \ \ m = \ n}" for m + proof - + have "infinite (range (\n. q (\ m, n)))" + unfolding q_def + using to_nat_on_infinite [OF co_\U inf_\U] finite_image_iff + by (simp add: finite_image_iff inj_on_def) + moreover have "(range (\n. q (\ m, n))) \ {n. \ m = \ n}" + using 11 [of "\ m"] by auto + ultimately have "infinite {n. \ m = \ n}" + using finite_subset by auto + then have "infinite ({n. \ m = \ n} - {.. n" "\ p = \ n" "\ m = \ n" "n < p" + with 16 [of n] show "x n < x p" + by (simp add: less_sets_def) (metis "*" "15" "17" Suc_lessI le_SucI subsetD) + qed + then have inj_x: "inj_on x (?eqv m)" for m + using strict_mono_on_imp_inj_on by blast + define ZA where "ZA \ \m. ?Z \ \ m (\ m)" + have small_ZA [simp]: "small (ZA m)" for m + by (metis ZA_def inf_le1 small_image_nat smaller_than_small) + have 19: "tp (ZA m) \ \" for m + proof - + have "x ` {n. m \ n \ \ m = \ n} \ ZA m" + unfolding ZA_def using "15" \_increasing_\ by blast + then have "infinite (ZA m)" + using INF [of m] finite_image_iff [OF inj_x] by (meson finite_subset) + then show ?thesis + by (simp add: ordertype_infinite_ge_\) + qed + have "\f \ elts \ \ ZA m. strict_mono_on f (elts \)" for m + proof - + obtain Z where "Z \ ZA m" "tp Z = \" + by (meson 19 Ord_\ le_ordertype_obtains_subset small_ZA) + moreover have "ZA m \ ON" + using Ord_in_Ord \_\\ \_in_\ unfolding ZA_def by blast + ultimately show ?thesis + by (metis strict_mono_on_ordertype Pi_mono small_ZA smaller_than_small subset_iff) + qed + then obtain \ where \: "\m. \ m \ elts \ \ ZA m" + and sm_\: "\m. strict_mono_on (\ m) (elts \)" + by metis + have "Ex(\(m,\). \ \ elts \ \ \ = \ * \ + ord_of_nat m)" if "\ \ elts (\ * \)" for \ + using that by (auto simp: mult [of \ \] lift_def elts_\) + then obtain split where split: "\\. \ \ elts (\ * \) \ + (\(m,\). \ \ elts \ \ \ = \ * \ + ord_of_nat m)(split \)" + by meson + have split_eq [simp]: "split (\ * \ + ord_of_nat m) = (m,\)" if "\ \ elts \" for \ m + proof - + have [simp]: "\ * \ + ord_of_nat m = \ * \ + ord_of_nat n \ \ = \ \ n = m" if "\ \ elts \" for \ n + by (metis Ord_\ that Ord_mem_iff_less_TC mult_cancellation_lemma ord_of_nat_\ ord_of_nat_inject) + show ?thesis + using split [of "\*\ + m"] that by (auto simp: mult [of \ \] lift_def cong: conj_cong) + qed + define \ where "\ \ \\. (\(m,\). \ (q(\,0)) m)(split \)" + have \_Pi: "\ \ elts (\ * \) \ (\m. ZA m)" + using \ by (fastforce simp: \_def mult [of \ \] lift_def elts_\) + moreover have "(\m. ZA m) \ ON" + unfolding ZA_def using \_\\ \_in_\ elts_subset_ON by blast + ultimately have Ord_\_Pi: "\ \ elts (\ * \) \ ON" + by fastforce + show "tp ?Z \ \ * \" + proof - + have \: "(\m. ZA m) = ?Z" + using "15" by (force simp: ZA_def) + moreover + have "tp (elts (\ * \)) \ tp (\m. ZA m)" + proof (rule ordertype_inc_le) + show "\ ` elts (\ * \) \ (\m. ZA m)" + using \_Pi by blast + next + fix u v + assume x: "u \ elts (\ * \)" and y: "v \ elts (\ * \)" and "(u,v) \ VWF" + then have "u Ord_in_Ord Ord_mult VWF_iff_Ord_less ord(2)) + moreover + obtain m \ n \ where ueq: "u = \ * \ + ord_of_nat m" and \: "\ \ elts \" + and veq: "v = \ * \ + ord_of_nat n" and \: "\ \ elts \" + using x y by (auto simp: mult [of \ \] lift_def elts_\) + ultimately have "\ \ \" + by (meson Ord_\ Ord_in_Ord Ord_linear2 \Ord \\ add_mult_less_add_mult less_asym ord_of_nat_\) + consider (eq) "\ = \" | (lt) "\ < \" + using \\ \ \\ le_neq_trans by blast + then have "\ u < \ v" + proof cases + case eq + then have "m < n" + using ueq veq \u by simp + then have "\ (q (\, 0)) m < \ (q (\, 0)) n" + using sm_\ strict_mono_onD by blast + then show ?thesis + using eq ueq veq \ \m < n\ by (simp add: \_def) + next + case lt + have "\ (q(\,0)) m \ \ (q(\,0)) (\(q(\,0)))" "\ (q (\,0)) n \ \ (q(\,0)) (\(q(\,0)))" + using \ unfolding ZA_def by blast+ + then show ?thesis + using lt ueq veq \ \ 18 [of "q(\,0)" "q(\,0)"] + by (simp add: \_def less_sets_def) + qed + then show "(\ u, \ v) \ VWF" + using \_Pi + by (metis Ord_\_Pi PiE VWF_iff_Ord_less x y mem_Collect_eq) + qed (use \ in auto) + ultimately show ?thesis by simp + qed + qed + then obtain Z where "Z \ ?Z" "tp Z = \ * \" + by (meson Ord_\ Ord_mult ord Z_sub down le_ordertype_obtains_subset) + ultimately show False + using iii [of Z] by (meson dual_order.trans image_mono nsets_mono) + qed + have False + if 0: "\H. tp H = ord_of_nat (2*k) \ H \ elts (\*\) \ \ f ` [H]\<^bsup>2\<^esup> \ {0}" + and 1: "\H. tp H = min \ (\ * \) \ H \ elts (\*\) \ \ f ` [H]\<^bsup>2\<^esup> \ {1}" + proof (cases "\*\ \ \") + case True + then have \: "\H'\H. tp H' = \ * \" if "tp H = \" "small H" for H + by (metis Ord_\ Ord_\1 Ord_in_Ord Ord_mult \ le_ordertype_obtains_subset that) + have [simp]: "min \ (\*\) = \*\" + by (simp add: min_absorb2 that True) + then show ?thesis + using * [OF 0] 1 True + by simp (meson \ down image_mono nsets_mono subset_trans) + next + case False + then have \: "\H'\H. tp H' = \" if "tp H = \ * \" "small H" for H + by (metis Ord_linear_le Ord_ordertype \Ord \\ le_ordertype_obtains_subset that) + then have "\ \ \*\" + by (meson Ord_\ Ord_\1 Ord_in_Ord Ord_linear_le Ord_mult \ \Ord \\ False) + then have [simp]: "min \ (\*\) = \" + by (simp add: min_absorb1) + then show ?thesis + using * [OF 0] 1 False + by simp (meson \ down image_mono nsets_mono subset_trans) + qed + then show "\iH\elts (\*\). tp H = [ord_of_nat (2*k), min \ (\*\)] ! i \ f ` [H]\<^bsup>2\<^esup> \ {i}" + by force + qed + qed +qed + + +theorem Erdos_Milner: + assumes \: "\ \ elts \1" + shows "partn_lst_VWF (\\(1 + \ * ord_of_nat n)) [ord_of_nat (2^n), \\(1+\)] 2" +proof (induction n) + case 0 + then show ?case + using partn_lst_VWF_degenerate [of 1 2] by simp +next + case (Suc n) + have "Ord \" + using Ord_\1 Ord_in_Ord assms by blast + have "1+\ \ \+1" + by (simp add: \Ord \\ one_V_def plus_Ord_le) + then have [simp]: "min (\ \ (1 + \)) (\ * \ \ \) = \ \ (1+\)" + by (simp add: \Ord \\ oexp_add min_def) + have ind: "indecomposable (\ \ (1 + \ * ord_of_nat n))" + by (simp add: \Ord \\ indecomposable_\_power) + show ?case + proof (cases "n = 0") + case True + then show ?thesis + using partn_lst_VWF_\_2 \Ord \\ one_V_def by auto + next + case False + then have "Suc 0 < 2 ^ n" + using less_2_cases not_less_eq by fastforce + then have "partn_lst_VWF (\ \ (1 + \ * n) * \ \ \) [ord_of_nat (2 * 2 ^ n), \ \ (1 + \)] 2" + using Erdos_Milner_aux [OF Suc ind, where \ = "\\\"] \Ord \\ \ + by (auto simp: countable_oexp) + then show ?thesis + using \Ord \\ by (simp add: mult_succ mult.assoc oexp_add) + qed +qed + + +corollary remark_3: "partn_lst_VWF (\\(Suc(4*k))) [4, \\(Suc(2*k))] 2" + using Erdos_Milner [of "2*k" 2] + apply (simp flip: ord_of_nat_mult ord_of_nat.simps) + by (simp add: one_V_def) + + +text \Theorem 3.2 of Jean A. Larson, ibid.\ +corollary Theorem_3_2: + fixes k n::nat + shows "partn_lst_VWF (\\(n*k)) [\\n, ord_of_nat k] 2" +proof (cases "n=0 \ k=0") + case True + then show ?thesis + by (auto intro: partn_lst_triv0 [where i=1] partn_lst_triv1 [where i=0] simp add:) +next + case False + then have "n > 0" "k > 0" + by auto + have PV: "partn_lst_VWF (\ \ (1 + ord_of_nat (n-1) * ord_of_nat (k-1))) [ord_of_nat (2 ^ (k-1)), \ \ (1 + ord_of_nat (n-1))] 2" + using Erdos_Milner [of "ord_of_nat (n-1)" "k-1"] Ord_\1 Ord_mem_iff_lt less_imp_le by blast + have "k+n \ Suc (Suc(k-1) * Suc(n-1))" + by simp + also have "\ \ Suc (k * n)" + using False by auto + finally have "1 + (n - 1) * (k - 1) \ (n*k)" + using False by (auto simp: algebra_simps) + then have "(1 + ord_of_nat (n - 1) * ord_of_nat (k - 1)) \ ord_of_nat(n*k)" + by (metis (mono_tags, lifting) One_nat_def one_V_def ord_of_nat.simps ord_of_nat_add ord_of_nat_mono_iff ord_of_nat_mult) + then have x: "\ \ (1 + ord_of_nat (n - 1) * ord_of_nat (k - 1)) \ \\(n*k)" + by (simp add: oexp_mono_le) + then have "partn_lst_VWF (\\(n*k)) [ord_of_nat (2 ^ (k-1)), \ \ (1 + ord_of_nat (n-1))] 2" + using Partitions.partn_lst_greater_resource PV x by blast + then have "partn_lst_VWF (\\(n*k)) [\ \ (1 + ord_of_nat (n-1)), ord_of_nat (2 ^ (k-1))] 2" + using partn_lst_two_swap by blast + moreover have "(1 + ord_of_nat (n-1)) = ord_of_nat n" + using ord_of_minus_1 [OF \n > 0\] + by (simp add: one_V_def) + ultimately have "partn_lst_VWF (\\(n*k)) [\ \ n, ord_of_nat (2 ^ (k-1))] 2" + by simp + then show ?thesis + using power_gt_expt [of 2 "k-1"] + by (force simp: less_Suc_eq intro: partn_lst_less) +qed + +end diff --git a/thys/Ordinal_Partitions/Library_Additions.thy b/thys/Ordinal_Partitions/Library_Additions.thy new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/Library_Additions.thy @@ -0,0 +1,1177 @@ +section \Library additions\ + +theory Library_Additions + imports "ZFC_in_HOL.Ordinal_Exp" "HOL-Library.Ramsey" "Nash_Williams.Nash_Williams" + +begin + +subsection \Already in the development version\ + +declare \_gt0 [simp] + +lemma irrefl_less_than: "irrefl less_than" + using irrefl_def by blast + +lemma total_on_less_than [simp]: "total_on A less_than" + using total_on_def by force+ + +lemma takeWhile_eq_Nil_iff: "takeWhile P xs = [] \ xs = [] \ \P (hd xs)" +by (cases xs) auto + +lemma lenlex_append1: + assumes len: "(us,xs) \ lenlex R" and eq: "length vs = length ys" + shows "(us @ vs, xs @ ys) \ lenlex R" + using len +proof (induction us) + case Nil + then show ?case + by (simp add: lenlex_def eq) +next + case (Cons u us) + with lex_append_rightI show ?case + by (fastforce simp add: lenlex_def eq) +qed + +lemma lenlex_append2 [simp]: + assumes "irrefl R" + shows "(us @ xs, us @ ys) \ lenlex R \ (xs, ys) \ lenlex R" +proof (induction us) + case Nil + then show ?case + by (simp add: lenlex_def) +next + case (Cons u us) + with assms show ?case + by (auto simp: lenlex_def irrefl_def) +qed + +lemma hd_concat: "\xs \ []; hd xs \ []\ \ hd (concat xs) = hd (hd xs)" + by (metis concat.simps(2) hd_Cons_tl hd_append2) + +lemma sorted_list_of_set_lessThan_Suc [simp]: + "sorted_list_of_set {..finite S; n < card S\ \ enumerate S n \ S" +proof (induction n arbitrary: S) + case 0 + then show ?case + by (metis all_not_in_conv card_empty enumerate.simps(1) not_less0 wellorder_Least_lemma(1)) +next + case (Suc n) + show ?case + using Suc.prems Suc.IH [of "S - {LEAST n. n \ S}"] + apply (simp add: enumerate.simps) + by (metis Diff_empty Diff_insert0 Suc_lessD card.remove less_Suc_eq) +qed + +lemma finite_enumerate_step: "\finite S; Suc n < card S\ \ enumerate S n < enumerate S (Suc n)" +proof (induction n arbitrary: S) + case 0 + then have "enumerate S 0 \ enumerate S (Suc 0)" + by (simp add: Least_le enumerate.simps(1) finite_enumerate_in_set) + moreover have "enumerate (S - {enumerate S 0}) 0 \ S - {enumerate S 0}" + by (metis 0 Suc_lessD Suc_less_eq card_Suc_Diff1 enumerate_in_set finite_enumerate_in_set) + then have "enumerate S 0 \ enumerate (S - {enumerate S 0}) 0" + by auto + ultimately show ?case + by (simp add: enumerate_Suc') +next + case (Suc n) + then show ?case + by (simp add: enumerate_Suc' finite_enumerate_in_set) +qed + +lemma finite_enumerate_mono: "\m < n; finite S; n < card S\ \ enumerate S m < enumerate S n" + by (induct m n rule: less_Suc_induct) (auto intro: finite_enumerate_step) + +lemma finite_enumerate_Suc'': + fixes S :: "'a::wellorder set" + assumes "finite S" "Suc n < card S" + shows "enumerate S (Suc n) = (LEAST s. s \ S \ enumerate S n < s)" + using assms +proof (induction n arbitrary: S) + case 0 + then have "\s \ S. enumerate S 0 \ s" + by (auto simp: enumerate.simps intro: Least_le) + then show ?case + unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"] + by (metis Diff_iff dual_order.strict_iff_order singletonD singletonI) +next + case (Suc n S) + then have "Suc n < card (S - {enumerate S 0})" + using Suc.prems(2) finite_enumerate_in_set by force + then show ?case + apply (subst (1 2) enumerate_Suc') + apply (simp add: Suc) + apply (intro arg_cong[where f = Least] HOL.ext) + using finite_enumerate_mono[OF zero_less_Suc \finite S\, of n] Suc.prems + by (auto simp flip: enumerate_Suc') +qed + +lemma finite_enumerate_initial_segment: + fixes S :: "'a::wellorder set" + assumes "finite S" and n: "n < card (S \ {.. {.. S \ n < s) = (LEAST n. n \ S)" + proof (rule Least_equality) + have "\t. t \ S \ t < s" + by (metis "0" card_gt_0_iff disjoint_iff_not_equal lessThan_iff) + then show "(LEAST n. n \ S) \ S \ (LEAST n. n \ S) < s" + by (meson LeastI Least_le le_less_trans) + qed (simp add: Least_le) + then show ?case + by (auto simp: enumerate_0) +next + case (Suc n) + then have less_card: "Suc n < card S" + by (meson assms(1) card_mono inf_sup_ord(1) leD le_less_linear order.trans) + obtain T where T: "T \ {s \ S. enumerate S n < s}" + by (metis Infinite_Set.enumerate_step enumerate_in_set finite_enumerate_in_set finite_enumerate_step less_card mem_Collect_eq) + have "(LEAST x. x \ S \ x < s \ enumerate S n < x) = (LEAST x. x \ S \ enumerate S n < x)" + (is "_ = ?r") + proof (intro Least_equality conjI) + show "?r \ S" + by (metis (mono_tags, lifting) LeastI mem_Collect_eq T) + have "\ s \ ?r" + using not_less_Least [of _ "\x. x \ S \ enumerate S n < x"] Suc assms + by (metis (mono_tags, lifting) Int_Collect Suc_lessD finite_Int finite_enumerate_in_set finite_enumerate_step lessThan_def less_le_trans) + then show "?r < s" + by auto + show "enumerate S n < ?r" + by (metis (no_types, lifting) LeastI mem_Collect_eq T) + qed (auto simp: Least_le) + then show ?case + using Suc assms by (simp add: finite_enumerate_Suc'' less_card) +qed + +lemma finite_enumerate_Ex: + fixes S :: "'a::wellorder set" + assumes S: "finite S" + and s: "s \ S" + shows "\ny\S. y < s") + case True + let ?T = "S \ {..finite S\]) + from True have y: "\x. Max ?T < x \ (\s'\S. s' < s \ s' < x)" + by (subst Max_less_iff) (auto simp: \finite ?T\) + then have y_in: "Max ?T \ {s'\S. s' < s}" + using Max_in \finite ?T\ by fastforce + with less.IH[of "Max ?T" ?T] obtain n where n: "enumerate ?T n = Max ?T" "n < card ?T" + using \finite ?T\ by blast + then have "Suc n < card S" + using TS less_trans_Suc by blast + with S n have "enumerate S (Suc n) = s" + by (subst finite_enumerate_Suc'') (auto simp: y finite_enumerate_initial_segment less finite_enumerate_Suc'' intro!: Least_equality) + then show ?thesis + using \Suc n < card S\ by blast + next + case False + then have "\t\S. s \ t" by auto + moreover have "0 < card S" + using card_0_eq less.prems by blast + ultimately show ?thesis + using \s \ S\ + by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0) + qed +qed + +lemma finite_bij_enumerate: + fixes S :: "'a::wellorder set" + assumes S: "finite S" + shows "bij_betw (enumerate S) {..n m. \n \ m; n < card S; m < card S\ \ enumerate S n \ enumerate S m" + using finite_enumerate_mono[OF _ \finite S\] by (auto simp: neq_iff) + then have "inj_on (enumerate S) {..s \ S. \ifinite S\ + ultimately show ?thesis + unfolding bij_betw_def by (auto intro: finite_enumerate_in_set) +qed + +lemma length_sorted_list_of_set [simp]: "length (sorted_list_of_set A) = card A" +proof (cases "finite A") + case True + then show ?thesis + by(metis distinct_card distinct_sorted_list_of_set set_sorted_list_of_set) +qed auto + +lemmas sorted_list_of_set = set_sorted_list_of_set sorted_sorted_list_of_set distinct_sorted_list_of_set + +lemma strict_sorted_equal: + assumes "strict_sorted xs" + and "strict_sorted ys" + and "set ys = set xs" + shows "ys = xs" + using assms +proof (induction xs arbitrary: ys) + case (Cons x xs) + show ?case + proof (cases ys) + case Nil + then show ?thesis + using Cons.prems by auto + next + case (Cons y ys') + then have "xs = ys'" + by (metis Cons.prems list.inject sorted_distinct_set_unique strict_sorted_iff) + moreover have "x = y" + using Cons.prems \xs = ys'\ local.Cons by fastforce + ultimately show ?thesis + using local.Cons by blast + qed +qed auto + +lemma sorted_list_of_set_inject: + assumes "sorted_list_of_set A = sorted_list_of_set B" "finite A" "finite B" + shows "A = B" + using assms set_sorted_list_of_set by fastforce + +lemma sorted_list_of_set_unique: + assumes "finite A" + shows "strict_sorted l \ set l = A \ length l = card A \ sorted_list_of_set A = l" + using assms strict_sorted_equal by force + +lemma iso_iff2: "iso r r' f \ + bij_betw f (Field r) (Field r') \ + (\a \ Field r. \b \ Field r. (a, b) \ r \ (f a, f b) \ r')" + (is "?lhs = ?rhs") +proof + assume L: ?lhs + then have "bij_betw f (Field r) (Field r')" and emb: "embed r r' f" + by (auto simp: bij_betw_def iso_def) + then obtain g where g: "\x. x \ Field r \ g (f x) = x" + by (auto simp: bij_betw_iff_bijections) + moreover + have "(a, b) \ r" if "a \ Field r" "b \ Field r" "(f a, f b) \ r'" for a b + using that emb g g [OF FieldI1] \\yes it's weird\ + by (force simp: embed_def under_def bij_betw_iff_bijections) + ultimately show ?rhs + using L by (auto simp: compat_def iso_def dest: embed_compat) +next + assume R: ?rhs + then show ?lhs + apply (clarsimp simp add: iso_def embed_def under_def bij_betw_iff_bijections) + apply (rule_tac x=g in exI) + apply (fastforce simp add: intro: FieldI1)+ + done +qed + +lemma sorted_list_of_set_atMost_Suc [simp]: + "sorted_list_of_set {..Suc k} = sorted_list_of_set {..k} @ [Suc k]" + using lessThan_Suc_atMost sorted_list_of_set_lessThan_Suc by fastforce + +lemma sorted_list_of_set_greaterThanLessThan: + assumes "Suc i < j" + shows "sorted_list_of_set {i<.. j" + shows "sorted_list_of_set {i<..j} = Suc i # sorted_list_of_set {Suc i<..j}" + using sorted_list_of_set_greaterThanLessThan [of i "Suc j"] + by (metis assms greaterThanAtMost_def greaterThanLessThan_eq le_imp_less_Suc lessThan_Suc_atMost) + +lemma nth_sorted_list_of_set_greaterThanLessThan: + "n < j - Suc i \ sorted_list_of_set {i<.. sorted_list_of_set {i<..j} ! n = Suc (i+n)" + using nth_sorted_list_of_set_greaterThanLessThan [of n "Suc j" i] + by (simp add: greaterThanAtMost_def greaterThanLessThan_eq lessThan_Suc_atMost) + +lemma inv_into_ordermap: "\ \ elts (ordertype A r) \ inv_into A (ordermap A r) \ \ A" + by (meson in_mono inv_into_into ordermap_surj) + +lemma elts_multE: + assumes "z \ elts (x * y)" + obtains u v where "u \ elts x" "v \ elts y" "z = x*v + u" + using mult [of x y] lift_def assms by auto + +lemma Ord_add_mult_iff: + assumes "\ \ elts \" "\' \ elts \" "Ord \" "Ord \'" "Ord \" + shows "\ * \ + \ \ elts (\ * \' + \') \ \ \ elts \' \ \ = \' \ \ \ elts \'" (is "?lhs \ ?rhs") +proof + assume L: ?lhs + show ?rhs + proof (cases "\ \ elts \'") + case False + with assms have "\ = \'" + by (meson L Ord_linear Ord_mult Ord_trans add_mult_less not_add_mem_right) + then show ?thesis + using L less_V_def by auto + qed auto +next + assume R: ?rhs + then show ?lhs + proof + assume "\ \ elts \'" + then obtain \ where "\' = \+\" + by (metis OrdmemD assms(3) assms(4) le_Ord_diff less_V_def) + show ?lhs + using assms + by (meson \\ \ elts \'\ add_le_cancel_left0 add_mult_less vsubsetD) + next + assume "\ = \' \ \ \ elts \'" + then show ?lhs + using less_V_def by auto + qed +qed + +lemma small_Times [simp]: + assumes "small A" "small B" + shows "small (A \ B)" +proof - + obtain f a g b where "inj_on f A" "inj_on g B" and f: "f ` A = elts a" and g: "g ` B = elts b" + using assms by (auto simp: small_def) + define h where "h \ \(x,y). \f x, g y\" + show ?thesis + unfolding small_def + proof (intro exI conjI) + show "inj_on h (A \ B)" + using \inj_on f A\ \inj_on g B\ by (simp add: h_def inj_on_def) + have "h ` (A \ B) = elts (vtimes a b)" + using f g by (fastforce simp: h_def image_iff split: prod.split) + then show "h ` (A \ B) \ range elts" + by blast + qed +qed + +lemma ordertype_Times: + assumes "small A" "small B" and r: "wf r" "trans r" "total_on A r" and s: "wf s" "trans s" "total_on B s" + shows "ordertype (A\B) (r <*lex*> s) = ordertype B s * ordertype A r" (is "_ = ?\ * ?\") +proof (subst ordertype_eq_iff) + show "Ord (?\ * ?\)" + by (intro wf_Ord_ordertype Ord_mult r s; simp) + define f where "f \ \(x,y). ?\ * ordermap A r x + (ordermap B s y)" + show "\f. bij_betw f (A \ B) (elts (?\ * ?\)) \ (\x\A \ B. \y\A \ B. (f x < f y) = ((x, y) \ (r <*lex*> s)))" + unfolding bij_betw_def + proof (intro exI conjI strip) + show "inj_on f (A \ B)" + proof (clarsimp simp: f_def inj_on_def) + fix x y x' y' + assume "x \ A" "y \ B" "x' \ A" "y' \ B" + and eq: "?\ * ordermap A r x + ordermap B s y = ?\ * ordermap A r x' + ordermap B s y'" + have "ordermap A r x = ordermap A r x' \ + ordermap B s y = ordermap B s y'" + proof (rule mult_cancellation_lemma [OF eq]) + show "ordermap B s y \ ?\" + using ordermap_in_ordertype [OF \y \ B\, of s] less_TC_iff \small B\ by blast + show "ordermap B s y' \ ?\" + using ordermap_in_ordertype [OF \y' \ B\, of s] less_TC_iff \small B\ by blast + qed + then show "x = x' \ y = y'" + using \x \ A\ \x' \ A\ \y \ B\ \y' \ B\ r s \small A\ \small B\ by auto + qed + show "f ` (A \ B) = elts (?\ * ?\)" (is "?lhs = ?rhs") + proof + show "f ` (A \ B) \ elts (?\ * ?\)" + apply (auto simp: f_def add_mult_less ordermap_in_ordertype wf_Ord_ordertype r s) + by (simp add: add_mult_less assms ordermap_in_ordertype wf_Ord_ordertype) + show "elts (?\ * ?\) \ f ` (A \ B)" + proof (clarsimp simp: f_def image_iff elim!: elts_multE split: prod.split) + fix u v + assume u: "u \ elts (?\)" and v: "v \ elts ?\" + have "inv_into B (ordermap B s) u \ B" + by (simp add: inv_into_ordermap u) + moreover have "inv_into A (ordermap A r) v \ A" + by (simp add: inv_into_ordermap v) + ultimately show "\x\A. \y\B. ?\ * v + u = ?\ * ordermap A r x + ordermap B s y" + by (metis \small A\ \small B\ bij_betw_inv_into_right ordermap_bij r(1) r(3) s(1) s(3) u v) + qed + qed + next + fix p q + assume "p \ A \ B" and "q \ A \ B" + then obtain u v x y where \
: "p = (u,v)" "u \ A" "v \ B" "q = (x,y)" "x \ A" "y \ B" + by blast + show "((f p) < f q) = ((p, q) \ (r <*lex*> s))" + proof + assume "f p < f q" + with \
assms have "(u, x) \ r \ u=x \ (v, y) \ s" + apply (simp add: f_def) + by (metis Ord_add Ord_add_mult_iff Ord_mem_iff_lt Ord_mult Ord_ordermap converse_ordermap_mono + ordermap_eq_iff ordermap_in_ordertype wf_Ord_ordertype) + then show "(p,q) \ (r <*lex*> s)" + by (simp add: \
) + next + assume "(p,q) \ (r <*lex*> s)" + then have "(u, x) \ r \ u = x \ (v, y) \ s" + by (simp add: \
) + then show "f p < f q" + proof + assume ux: "(u, x) \ r" + have oo: "\x. Ord (ordermap A r x)" "\y. Ord (ordermap B s y)" + by (simp_all add: r s) + show "f p < f q" + proof (clarsimp simp: f_def split: prod.split) + fix a b a' b' + assume "p = (a, b)" and "q = (a', b')" + then have "?\ * ordermap A r a + ordermap B s b < ?\ * ordermap A r a'" + using ux assms \
+ by (metis Ord_mult Ord_ordermap OrdmemD Pair_inject add_mult_less ordermap_in_ordertype ordermap_mono wf_Ord_ordertype) + also have "\ \ ?\ * ordermap A r a' + ordermap B s b'" + by simp + finally show "?\ * ordermap A r a + ordermap B s b < ?\ * ordermap A r a' + ordermap B s b'" . + qed + next + assume "u = x \ (v, y) \ s" + then show "f p < f q" + using \
assms by (fastforce simp: f_def split: prod.split intro: ordermap_mono_less) + qed + qed + qed +qed (use assms small_Times in auto) + +lemma ordertype_nat_\: + assumes "infinite N" shows "ordertype N less_than = \" +proof - + have "small N" + by (meson inj_on_def ord_of_nat_inject small_def small_iff_range small_image_nat_V) + have "ordertype (ord_of_nat ` N) VWF = \" + by (force simp: assms finite_image_iff inj_on_def intro: ordertype_infinite_\) + moreover have "ordertype (ord_of_nat ` N) VWF = ordertype N less_than" + using total_on_def by (fastforce intro!: ordertype_inc_eq \small N\) + ultimately show ?thesis + by simp +qed +lemma infinite_infinite_partition: + assumes "infinite A" + obtains C :: "nat \ 'a set" + where "pairwise (\i j. disjnt (C i) (C j)) UNIV" "(\i. C i) \ A" "\i. infinite (C i)" +proof - + obtain f :: "nat\'a" where "range f \ A" "inj f" + using assms infinite_countable_subset by blast + let ?C = "\i. range (\j. f (prod_encode (i,j)))" + show thesis + proof + show "pairwise (\i j. disjnt (?C i) (?C j)) UNIV" + by (auto simp: pairwise_def disjnt_def inj_on_eq_iff [OF \inj f\] inj_on_eq_iff [OF inj_prod_encode, of _ UNIV]) + show "(\i. ?C i) \ A" + using \range f \ A\ by blast + have "infinite (range (\j. f (prod_encode (i, j))))" for i + by (rule range_inj_infinite) (meson Pair_inject \inj f\ inj_def prod_encode_eq) + then show "\i. infinite (?C i)" + using that by auto + qed +qed + +text \This is already installed in the development AFP entry\ +lemma mult_cancellation_half: + assumes "a*x + r \ a*y + s" "r \ a" "s \ a" + shows "x \ y" +proof - + have "x \ y" if "Ord \" "x \ elts (Vset \)" "y \ elts (Vset \)" for \ + using that assms + proof (induction \ arbitrary: x y r s rule: Ord_induct3) + case 0 + then show ?case + by auto + next + case (succ k) + show ?case + proof + fix u + assume u: "u \ elts x" + have u_k: "u \ elts (Vset k)" + using Vset_succ succ.hyps succ.prems(1) u by auto + obtain r' where "r' \ elts a" "r \ r'" + using less_TC_iff succ.prems(4) by blast + have "a*u + r' \ elts (lift (a*u) a)" + by (simp add: \r' \ elts a\ lift_def) + also have "\ \ elts (a*x)" + using u by (force simp: mult [of _ x]) + also have "\ \ elts (a*y + s)" + using plus_eq_lift succ.prems(3) by auto + also have "\ = elts (a*y) \ elts (lift (a*y) s)" + by (simp add: plus_eq_lift) + finally have "a * u + r' \ elts (a * y) \ elts (lift (a * y) s)" . + then show "u \ elts y" + proof + assume *: "a * u + r' \ elts (a * y)" + show "u \ elts y" + proof - + obtain v e where v: "v \ elts y" "e \ elts a" "a * u + r' = a * v + e" + using * by (auto simp: mult [of _ y] lift_def) + then have v_k: "v \ elts (Vset k)" + using Vset_succ_TC less_TC_iff succ.prems(2) by blast + then show ?thesis + by (metis \r' \ elts a\ antisym le_TC_refl less_TC_iff order_refl succ.IH u_k v) + qed + next + assume "a * u + r' \ elts (lift (a * y) s)" + then obtain t where "t \ elts s" and t: "a * u + r' = a * y + t" + using lift_def by auto + have noteq: "a*y \ a*u" + proof + assume "a*y = a*u" + then have "lift (a*y) a = lift (a*u) a" + by metis + also have "\ \ a*x" + unfolding mult [of _ x] using \u \ elts x\ by (auto intro: cSUP_upper) + also have "\ \ a*y \ lift (a*y) s" + using \elts (a * x) \ elts (a * y + s)\ plus_eq_lift by auto + finally have "lift (a*y) a \ a*y \ lift (a*y) s" . + then have "lift (a*y) a \ lift (a*y) s" + using add_le_cancel_left less_TC_imp_not_le plus_eq_lift \s \ a\ by auto + then have "a \ s" + by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib) + then show False + using \s \ a\ less_TC_imp_not_le by auto + qed + consider "a * u \ a * y" | "a * y \ a * u" + using t comparable vle_comparable_def by blast + then have "False" + proof cases + case 1 + then obtain c where "a*y = a*u + c" + by (metis vle_def) + then have "c+t = r'" + by (metis add_right_cancel add.assoc t) + then have "c \ a" + using \r' \ elts a\ less_TC_iff vle2 vle_def by force + moreover have "c \ 0" + using \a * y = a * u + c\ noteq by auto + ultimately show ?thesis + using \a * y = a * u + c\ mult_eq_imp_0 by blast + next + case 2 + then obtain c where "a*u = a*y + c" + by (metis vle_def) + then have "c+r' = t" + by (metis add_right_cancel add.assoc t) + then have "c \ a" + by (metis \t \ elts s\ less_TC_iff less_TC_trans \s \ a\ vle2 vle_def) + moreover have "c \ 0" + using \a * u = a * y + c\ noteq by auto + ultimately show ?thesis + using \a * u = a * y + c\ mult_eq_imp_0 by blast + qed + then show "u \ elts y" .. + qed + qed + next + case (Limit k) + obtain i j where k: "i \ elts k" "j \ elts k" + and x: "x \ elts (Vset i)" and y: "y \ elts (Vset j)" + using that Limit by (auto simp: Limit_Vfrom_eq) + show ?case + proof (rule Limit.IH [of "i \ j"]) + show "i \ j \ elts k" + by (meson k x y Limit.hyps Limit_def Ord_in_Ord Ord_mem_iff_lt Ord_sup union_less_iff) + show "x \ elts (Vset (i \ j))" "y \ elts (Vset (i \ j))" + using x y by (auto simp: Vfrom_sup) + show "a * x + r \ a * y + s" + by (simp add: Limit.prems) + qed (auto simp: Limit.prems) + qed + then show ?thesis + by (metis two_in_Vset Ord_rank Ord_VsetI rank_lt) +qed + +corollary mult_cancellation_less: + assumes lt: "a*x + r < a*y + s" and "r \ a" "s \ a" + obtains "x < y" | "x = y" "r < s" +proof - + have "x \ y" + by (meson assms dual_order.strict_implies_order mult_cancellation_half) + then consider "x < y" | "x = y" + using less_V_def by blast + with lt that show ?thesis by blast +qed + +subsection \For HOL\ + +lemma enumerate_mono_iff [simp]: + "infinite S \ enumerate S m < enumerate S n \ m < n" + by (metis enumerate_mono less_asym less_linear) + +lemma finite_enumerate_mono_iff [simp]: + "\finite S; m < card S; n < card S\ \ enumerate S m < enumerate S n \ m < n" + by (metis finite_enumerate_mono less_asym less_linear) + +lemma finite_enumerate_Diff_singleton: + fixes S :: "'a::wellorder set" + assumes "finite S" and i: "i < card S" "enumerate S i < x" + shows "enumerate (S - {x}) i = enumerate S i" + using i +proof (induction i) + case 0 + have "(LEAST i. i \ S \ i\x) = (LEAST i. i \ S)" + proof (rule Least_equality) + have "\t. t \ S \ t\x" + using 0 \finite S\ finite_enumerate_in_set by blast + then show "(LEAST i. i \ S) \ S \ (LEAST i. i \ S) \ x" + by (metis "0.prems"(2) LeastI enumerate_0 not_less_Least) + qed (simp add: Least_le) + then show ?case + by (auto simp: enumerate_0) +next + case (Suc i) + then have x: "enumerate S i < x" + by (meson enumerate_step finite_enumerate_step less_trans) + have cardSx: "Suc i < card (S - {x})" and "i < card S" + using Suc \finite S\ card_Diff_singleton_if finite_enumerate_Ex by fastforce+ + have "(LEAST s. s \ S \ s\x \ enumerate (S - {x}) i < s) = (LEAST s. s \ S \ enumerate S i < s)" + (is "_ = ?r") + proof (intro Least_equality conjI) + show "?r \ S" + by (metis (lifting) LeastI Suc.prems(1) assms(1) finite_enumerate_in_set finite_enumerate_step) + show "?r \ x" + using Suc.prems not_less_Least [of _ "\t. t \ S \ enumerate S i < t"] + \finite S\ finite_enumerate_in_set finite_enumerate_step by blast + show "enumerate (S - {x}) i < ?r" + by (metis (full_types) Suc.IH Suc.prems(1) \i < card S\ enumerate_Suc'' enumerate_step finite_enumerate_Suc'' finite_enumerate_step x) + show "\y. y \ S \ y \ x \ enumerate (S - {x}) i < y \ ?r \ y" + by (simp add: Least_le Suc.IH \i < card S\ x) + qed + then show ?case + using Suc assms by (simp add: finite_enumerate_Suc'' cardSx) +qed + + + +lemma lexl_not_refl [simp]: "irrefl r \ (x,x) \ lex r" + by (meson irrefl_def lex_take_index) + +lemma hd_lex: "\hd ms < hd ns; length ms = length ns; ns \ []\ \ (ms, ns) \ lex less_than" + by (metis hd_Cons_tl length_0_conv less_than_iff lexord_cons_cons lexord_lex) + + +lemma finite_enum_subset: + assumes "\i. i < card X \ enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X \ card Y" + shows "X \ Y" + by (metis assms finite_enumerate_Ex finite_enumerate_in_set less_le_trans subsetI) + +lemma finite_enum_ext: + assumes "\i. i < card X \ enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X = card Y" + shows "X = Y" + by (intro antisym finite_enum_subset) (auto simp: assms) + +thm card_Un_disjoint +lemma card_Un_disjnt: "\finite A; finite B; disjnt A B\ \ card (A \ B) = card A + card B" + by (simp add: card_Un_disjoint disjnt_def) + + +lemma sorted_list_of_set_nonempty: + assumes "finite I" "I \ {}" + shows "sorted_list_of_set I = Min I # sorted_list_of_set (I - {Min I})" + using assms by (auto simp: less_le simp flip: sorted_list_of_set_unique intro: Min_in) +lemma strict_sorted_imp_sorted: "strict_sorted xs \ sorted xs" + by (auto simp: strict_sorted_iff) + +lemma sorted_hd_le: + assumes "sorted xs" "x \ list.set xs" + shows "hd xs \ x" + using assms by (induction xs) (auto simp: less_imp_le) + +lemma sorted_le_last: + assumes "sorted xs" "x \ list.set xs" + shows "x \ last xs" + using assms by (induction xs) (auto simp: less_imp_le) + +lemma hd_list_of: + assumes "finite A" "A \ {}" + shows "hd (sorted_list_of_set A) = Min A" +proof (rule antisym) + have "Min A \ A" + by (simp add: assms) + then show "hd (sorted_list_of_set A) \ Min A" + by (simp add: sorted_hd_le \finite A\) +next + show "Min A \ hd (sorted_list_of_set A)" + by (metis Min_le assms hd_in_set set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff) +qed + +lemma sorted_hd_le_last: + assumes "sorted xs" "xs \ []" + shows "hd xs \ last xs" + using assms by (simp add: sorted_hd_le) + +lemma sorted_list_of_set_set_of [simp]: "strict_sorted l \ sorted_list_of_set (list.set l) = l" + by (simp add: strict_sorted_equal) + +lemma finite_Inf_in: + fixes A :: "'a::complete_lattice set" + assumes "finite A" "A\{}" and inf: "\x y. \x \ A; y \ A\ \ inf x y \ A" + shows "Inf A \ A" +proof - + have "Inf B \ A" if "B \ A" "B\{}" for B + using finite_subset [OF \B \ A\ \finite A\] that + by (induction B) (use inf in \force+\) + then show ?thesis + by (simp add: assms) +qed + +lemma finite_Sup_in: + fixes A :: "'a::complete_lattice set" + assumes "finite A" "A\{}" and sup: "\x y. \x \ A; y \ A\ \ sup x y \ A" + shows "Sup A \ A" +proof - + have "Sup B \ A" if "B \ A" "B\{}" for B + using finite_subset [OF \B \ A\ \finite A\] that + by (induction B) (use sup in \force+\) + then show ?thesis + by (simp add: assms) +qed + +lemma range_strict_mono_ext: + fixes f::"nat \ 'a::linorder" + assumes eq: "range f = range g" + and sm: "strict_mono f" "strict_mono g" + shows "f = g" +proof + fix n + show "f n = g n" + proof (induction n rule: less_induct) + case (less n) + obtain x y where xy: "f n = g y" "f x = g n" + by (metis eq imageE rangeI) + then have "n = y" + by (metis (no_types) less.IH neq_iff sm strict_mono_less xy) + then show ?case using xy by auto + qed +qed + +(*METIS NOT ALLOWED!*) + +lemma iso_trans: + assumes "trans r" "iso r r' f" shows "trans r'" + using assms unfolding trans_def iso_iff2 bij_betw_iff_bijections + by (metis (full_types) FieldI1 FieldI2) + +lemma iso_Total: + assumes "Total r" "iso r r' f" shows "Total r'" + using assms unfolding total_on_def iso_iff2 bij_betw_iff_bijections by metis + +lemma iso_wf: + assumes "wf r" "iso r r' f" shows "wf r'" +proof - + have bij: "bij_betw f (Field r) (Field r')" + and iff: "(\a \ Field r. \b \ Field r. (a, b) \ r \ (f a, f b) \ r')" + using assms by (auto simp: iso_iff2) + show ?thesis + proof (rule wfI_min) + fix x::'b and Q + assume "x \ Q" + let ?Q = "inv_into (Field r) f ` Q" + obtain z where "z \ ?Q" "\x y. \(y, z) \ r; x \ Q\ \ y \ inv_into (Field r) f x" + by (metis \x \ Q\ \wf r\ image_eqI wfE_min) + with bij show "\z\Q. \y. (y, z) \ r' \ y \ Q" + by (metis (no_types, lifting) FieldI2 bij_betw_imp_surj_on f_inv_into_f iff inv_into_into) + qed +qed + + +subsection \Also in the Nash-Williams development\ +text \FIXME: these contain duplicates and need consolidation\ + +lemma less_setsD: "\less_sets A B; a \ A; b \ B\ \ a < b" + by (auto simp: less_sets_def) + +lemma less_sets_irrefl [simp]: "less_sets A A \ A = {}" + by (auto simp: less_sets_def) + +lemma less_sets_trans: "\less_sets A B; less_sets B C; B \ {}\ \ less_sets A C" + unfolding less_sets_def using less_trans by blast + +lemma less_sets_weaken1: "\less_sets A' B; A \ A'\ \ less_sets A B" + by (auto simp: less_sets_def) + +lemma less_sets_weaken2: "\less_sets A B'; B \ B'\ \ less_sets A B" + by (auto simp: less_sets_def) + +lemma less_sets_imp_disjnt: "less_sets A B \ disjnt A B" + by (auto simp: less_sets_def disjnt_def) + +lemma less_sets_Un1: "less_sets (A \ A') B \ less_sets A B \ less_sets A' B" + by (auto simp: less_sets_def) + +lemma less_sets_Un2: "less_sets A (B \ B') \ less_sets A B \ less_sets A B'" + by (auto simp: less_sets_def) + +lemma less_sets_UN1: "less_sets (\\) B \ (\A\\. less_sets A B)" + by (auto simp: less_sets_def) + +lemma less_sets_UN2: "less_sets A (\ \) \ (\B\\. less_sets A B)" + by (auto simp: less_sets_def) + +lemma strict_sorted_imp_less_sets: + "strict_sorted (as @ bs) \ less_sets (list.set as) (list.set bs)" + by (simp add: less_sets_def sorted_wrt_append strict_sorted_sorted_wrt) + +subsection \Other material\ + +definition strict_mono_sets :: "['a::order set, 'a::order \ 'b::order set] \ bool" where + "strict_mono_sets A f \ \x\A. \y\A. x < y \ less_sets (f x) (f y)" + +lemma strict_mono_setsD: + assumes "strict_mono_sets A f" "x < y" "x \ A" "y \ A" + shows "less_sets (f x) (f y)" + using assms by (auto simp: strict_mono_sets_def) + +lemma strict_mono_on_o: "\strict_mono_on r A; strict_mono_on s B; s ` B \ A\ \ strict_mono_on (r \ s) B" + by (auto simp: image_subset_iff strict_mono_on_def) + +lemma strict_mono_sets_imp_disjoint: + fixes A :: "'a::linorder set" + assumes "strict_mono_sets A f" + shows "pairwise (\x y. disjnt (f x) (f y)) A" + using assms unfolding strict_mono_sets_def pairwise_def + by (meson antisym_conv3 disjnt_sym less_sets_imp_disjnt) + +lemma strict_mono_sets_subset: + assumes "strict_mono_sets B f" "A \ B" + shows "strict_mono_sets A f" + using assms by (auto simp: strict_mono_sets_def) + +lemma strict_mono_less_sets_Min: + assumes "strict_mono_sets I f" "finite I" "I \ {}" + shows "less_sets (f (Min I)) (\ (f ` (I - {Min I})))" + using assms by (simp add: strict_mono_sets_def less_sets_UN2 dual_order.strict_iff_order) + +lemma pair_less_iff1 [simp]: "((x,y), (x,z)) \ pair_less \ y" "\\{}" "\A. A \ \ \ infinite A" + and "\A B. \A \ \; B \ \\ \ A \ B \ \" + shows "infinite (\\)" + by (simp add: assms finite_Inf_in) + +lemma atLeast_less_sets: "\less_sets A {x}; B \ {x..}\ \ less_sets A B" + by (force simp: less_sets_def subset_iff) + + + +subsection \The list-of function\ + +(*NOT THE FOLLOWING*) + +lemma sorted_list_of_set_insert: + assumes "finite A" "less_sets {a} A" + shows "sorted_list_of_set (insert a A) = a # sorted_list_of_set A" +proof - + have "strict_sorted (a # sorted_list_of_set A)" + using assms less_setsD by auto + moreover have "list.set (a # sorted_list_of_set A) = insert a A" + using assms by force + moreover have "length (a # sorted_list_of_set A) = card (insert a A)" + using assms card_insert_if less_setsD by fastforce + ultimately show ?thesis + by (metis assms(1) finite_insert sorted_list_of_set_unique) +qed + +lemma sorted_list_of_set_Un: + assumes AB: "less_sets A B" and fin: "finite A" "finite B" + shows "sorted_list_of_set (A \ B) = sorted_list_of_set A @ sorted_list_of_set B" +proof - + have "strict_sorted (sorted_list_of_set A @ sorted_list_of_set B)" + using AB unfolding less_sets_def + by (metis fin set_sorted_list_of_set sorted_wrt_append strict_sorted_list_of_set strict_sorted_sorted_wrt) + moreover have "card A + card B = card (A \ B)" + using less_sets_imp_disjnt [OF AB] + by (simp add: assms card_Un_disjoint disjnt_def) + ultimately show ?thesis + by (simp add: assms strict_sorted_equal) +qed + +lemma sorted_list_of_set_UN_lessThan: + fixes k::nat + assumes sm: "strict_mono_sets {..i. i < k \ finite (A i)" + shows "sorted_list_of_set (\i A) (sorted_list_of_set {.. (A ` {.. (A ` {.. (A ` {.. A k)" + by (simp add: Un_commute lessThan_Suc) + also have "\ = sorted_list_of_set (\ (A ` {.. = concat (map (sorted_list_of_set \ A) (sorted_list_of_set {.. = concat (map (sorted_list_of_set \ A) (sorted_list_of_set {..i. i \ k \ finite (A i)" + shows "sorted_list_of_set (\i\k. A i) = concat (map (sorted_list_of_set \ A) (sorted_list_of_set {..k}))" + by (metis assms lessThan_Suc_atMost less_Suc_eq_le sorted_list_of_set_UN_lessThan) + + + +subsection \Ramsey\ + +lemma nsets_Pi_contra: "A' \ A \ Pi ([A]\<^bsup>n\<^esup>) B \ Pi ([A']\<^bsup>n\<^esup>) B" + by (auto simp: nsets_def) + +subsection \Misc additions to the ZF libraries\ + + +lemma oexp_\_Limit: "Limit \ \ \\\ = (SUP \ \ elts \. \\\)" + by (simp add: oexp_Limit) + + +lemma oexp_mult_commute: + fixes j::nat + shows "Ord \ \ (\ \ j) * \ = \ * (\ \ j)" + by (metis Ord_1 Ord_ord_of_nat oexp_1_right oexp_add oexp_succ one_V_def ord_of_nat_\ succ_0_plus_eq) + +lemma iso_imp_ordertype_eq_ordertype: + assumes iso: "iso r r' f" + and "wf r" + and "Total r" + and "trans r" + and sm: "small (Field r)" + shows "ordertype (Field r) r = ordertype (Field r') r'" +proof (subst ordertype_eq_ordertype) + show "small (Field r')" + by (metis iso sm iso_Field replacement) + show "\f. bij_betw f (Field r) (Field r') \ (\x\Field r. \y\Field r. ((f x, f y) \ r') = ((x, y) \ r))" + using assms(1) iso_iff2 by blast +qed (use assms iso_wf iso_Total iso_trans in auto) + +proposition ordertype_eq_ordertype_iso: + assumes r: "wf r" "total_on A r" "trans r" and "small A" and FA: "Field r = A" + assumes s: "wf s" "total_on B s" "trans s" and "small B" and FB: "Field s = B" + shows "ordertype A r = ordertype B s \ (\f. iso r s f)" + (is "?lhs = ?rhs") +proof + assume L: ?lhs + then obtain f where "bij_betw f A B" "\x \ A. \y \ A. (f x, f y) \ s \ (x,y) \ r" + using assms ordertype_eq_ordertype by blast + then show ?rhs + using FA FB iso_iff2 by blast +next + assume ?rhs + then show ?lhs + using FA FB \small A\ iso_imp_ordertype_eq_ordertype r by blast +qed + +lemma total_on_imp_Total_Restr: "total_on A r \ Total (Restr r A)" + by (auto simp: Field_def total_on_def) + +lemma Limit_ordertype_imp_Field_Restr: + assumes Lim: "Limit (ordertype A r)" and r: "wf r" "total_on A r" and "small A" + shows "Field (Restr r A) = A" +proof - + have "\y\A. (x,y) \ r" if "x \ A" for x + proof - + let ?oy = "succ (ordermap A r x)" + have \
: "?oy \ elts (ordertype A r)" + by (simp add: Lim \small A\ ordermap_in_ordertype succ_in_Limit_iff that) + then have A: "inv_into A (ordermap A r) ?oy \ A" + by (simp add: inv_into_ordermap) + moreover have "(x, inv_into A (ordermap A r) ?oy) \ r" + proof - + have "ordermap A r x \ elts (ordermap A r (inv_into A (ordermap A r) ?oy))" + by (metis "\
" elts_succ f_inv_into_f insert_iff ordermap_surj subsetD) + then show ?thesis + by (metis \small A\ A converse_ordermap_mono r that) + qed + ultimately show ?thesis .. + qed + then have "A \ Field (Restr r A)" + by (auto simp: Field_def) + then show ?thesis + by (simp add: Field_Restr_subset subset_antisym) +qed + +lemma ordertype_Field_Restr: + assumes "wf r" "total_on A r" "trans r" "small A" "Field (Restr r A) = A" + shows "ordertype (Field (Restr r A)) (Restr r A) = ordertype A r" + using assms by (force simp: ordertype_eq_ordertype wf_Restr total_on_def trans_Restr) + +proposition ordertype_eq_ordertype_iso_Restr: + assumes r: "wf r" "total_on A r" "trans r" and "small A" and FA: "Field (Restr r A) = A" + assumes s: "wf s" "total_on B s" "trans s" and "small B" and FB: "Field (Restr s B) = B" + shows "ordertype A r = ordertype B s \ (\f. iso (Restr r A) (Restr s B) f)" + (is "?lhs = ?rhs") +proof + assume L: ?lhs + then obtain f where "bij_betw f A B" "\x \ A. \y \ A. (f x, f y) \ s \ (x,y) \ r" + using assms ordertype_eq_ordertype by blast + then show ?rhs + using FA FB bij_betwE unfolding iso_iff2 by fastforce +next + assume ?rhs + moreover + have "ordertype (Field (Restr r A)) (Restr r A) = ordertype A r" + using FA \small A\ ordertype_Field_Restr r by blast + moreover + have "ordertype (Field (Restr s B)) (Restr s B) = ordertype B s" + using FB \small B\ ordertype_Field_Restr s by blast + ultimately show ?lhs + using iso_imp_ordertype_eq_ordertype FA FB \small A\ r + by (fastforce intro: total_on_imp_Total_Restr trans_Restr wf_Int1) +qed + +subsection \Monotonic enumeration of a countably infinite set\ + +abbreviation "enum \ enumerate" + +text \Could be generalised to infinite countable sets of any type\ +lemma nat_infinite_iff: + fixes N :: "nat set" + shows "infinite N \ (\f::nat\nat. N = range f \ strict_mono f)" +proof safe + assume "infinite N" + then show "\f. N = range (f::nat \ nat) \ strict_mono f" + by (metis bij_betw_imp_surj_on bij_enumerate enumerate_mono strict_mono_def) +next + fix f :: "nat \ nat" + assume "strict_mono f" and "N = range f" and "finite (range f)" + then show False + using range_inj_infinite strict_mono_imp_inj_on by blast +qed + +lemma enum_works: + fixes N :: "nat set" + assumes "infinite N" + shows "N = range (enum N) \ strict_mono (enum N)" + by (metis assms bij_betw_imp_surj_on bij_enumerate enumerate_mono strict_monoI) + +lemma range_enum: "range (enum N) = N" and strict_mono_enum: "strict_mono (enum N)" + if "infinite N" for N :: "nat set" + using enum_works [OF that] by auto + +lemma enum_0_eq_Inf: + fixes N :: "nat set" + assumes "infinite N" + shows "enum N 0 = Inf N" +proof - + have "enum N 0 \ N" + using assms range_enum by auto + moreover have "\x. x \ N \ enum N 0 \ x" + by (metis (mono_tags, hide_lams) assms imageE le0 less_mono_imp_le_mono range_enum strict_monoD strict_mono_enum) + ultimately show ?thesis + by (metis cInf_eq_minimum) +qed + +lemma enum_works_finite: + fixes N :: "nat set" + assumes "finite N" + shows "N = enum N ` {.. strict_mono_on (enum N) {.. N" "finite N" + obtains i where "i < card N" "x = enum N i" + by (metis \x \ N\ \finite N\ enum_works_finite imageE lessThan_iff) + +lemma enum_0_eq_Inf_finite: + fixes N :: "nat set" + assumes "finite N" "N \ {}" + shows "enum N 0 = Inf N" +proof - + have "enum N 0 \ N" + by (metis Nat.neq0_conv assms empty_is_image enum_works_finite image_eqI lessThan_empty_iff lessThan_iff) + moreover have "enum N 0 \ x" if "x \ N" for x + proof - + obtain i where "i < card N" "x = enum N i" + by (metis \x \ N\ \finite N\ enum_obtain_index_finite) + with assms show ?thesis + by (metis Nat.neq0_conv finite_enumerate_mono less_or_eq_imp_le) + qed + ultimately show ?thesis + by (metis cInf_eq_minimum) +qed + +lemma greaterThan_less_enum: + fixes N :: "nat set" + assumes "N \ {x<..}" "infinite N" + shows "x < enum N i" + using assms range_enum by fastforce + +lemma atLeast_le_enum: + fixes N :: "nat set" + assumes "N \ {x..}" "infinite N" + shows "x \ enum N i" + using assms range_enum by fastforce + +lemma less_sets_empty1 [simp]: "less_sets {} A" and less_sets_empty2 [simp]: "less_sets A {}" + by (simp_all add: less_sets_def) + +lemma less_sets_singleton1 [simp]: "less_sets {a} A \ (\x\A. a < x)" + and less_sets_singleton2 [simp]: "less_sets A {a} \ (\x\A. x < a)" + by (simp_all add: less_sets_def) + +lemma less_sets_atMost [simp]: "less_sets {..a} A \ (\x\A. a < x)" + and less_sets_alLeast [simp]: "less_sets A {a..} \ (\x\A. x < a)" + by (auto simp: less_sets_def) + +lemma less_sets_imp_strict_mono_sets: + assumes "\i. less_sets (A i) (A (Suc i))" "\i. i>0 \ A i \ {}" + shows "strict_mono_sets UNIV A" +proof (clarsimp simp: strict_mono_sets_def) + fix i j::nat + assume "i < j" + then show "less_sets (A i) (A j)" + proof (induction "j-i" arbitrary: i j) + case (Suc x) + then show ?case + by (metis Suc_diff_Suc Suc_inject Suc_mono assms less_Suc_eq less_sets_trans zero_less_Suc) + qed auto +qed + +lemma less_sets_Suc_Max: + assumes "finite A" + shows "less_sets A {Suc (Max A)..}" +proof (cases "A = {}") + case False + then show ?thesis + by (simp add: assms less_Suc_eq_le) +qed auto + +lemma infinite_nat_greaterThan: + fixes m::nat + assumes "infinite N" + shows "infinite (N \ {m<..})" +proof - + have "N \ -{m<..} \ (N \ {m<..})" + by blast + moreover have "finite (-{m<..})" + by simp + ultimately show ?thesis + using assms finite_subset by blast +qed + +end + + + diff --git a/thys/Ordinal_Partitions/Omega_Omega.thy b/thys/Ordinal_Partitions/Omega_Omega.thy new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/Omega_Omega.thy @@ -0,0 +1,4670 @@ +section \An ordinal partition theorem by Jean A. Larson\ + +text \Jean A. Larson, + A short proof of a partition theorem for the ordinal $\omega^\omega$. + \emph{Annals of Mathematical Logic}, 6:129–145, 1973.\ + +theory Omega_Omega + imports "HOL-Library.Product_Lexorder" Erdos_Milner + +begin + +abbreviation "list_of \ sorted_list_of_set" + +subsection \Cantor normal form for ordinals below @{term "\\\"}\ + +text \Unlike @{term Cantor_sum}, there is no list of ordinal exponents, +which are instead taken as consecutive. We obtain an order-isomorphism between @{term "\\\"} +and increasing lists of natural numbers (ordered lexicographically).\ + +fun omega_sum_aux where + Nil: "omega_sum_aux 0 _ = 0" +| Suc: "omega_sum_aux (Suc n) [] = 0" +| Cons: "omega_sum_aux (Suc n) (m#ms) = (\\n) * (ord_of_nat m) + omega_sum_aux n ms" + +abbreviation omega_sum where "omega_sum ms \ omega_sum_aux (length ms) ms" + +text \A normal expansion has no leading zeroes\ +primrec normal:: "nat list \ bool" where + normal_0: "normal [] = True" +| normal_Suc: "normal (m#ms) = (m > 0)" + +lemma omega_sum_0_iff [simp]: "normal ns \ omega_sum ns = 0 \ ns = []" + by (induction ns) auto + +lemma Ord_omega_sum_aux [simp]: "Ord (omega_sum_aux k ms)" + by (induction rule: omega_sum_aux.induct) auto + +lemma Ord_omega_sum: "Ord (omega_sum ms)" + by simp + +lemma omega_sum_less_\\ [intro]: "omega_sum ms < \\\" +proof (induction ms) + case Nil + then show ?case + by (auto simp: zero_less_Limit) +next + case (Cons m ms) + have "\ \ (length ms) * ord_of_nat m \ elts (\ \ Suc (length ms))" + using Ord_mem_iff_lt by auto + then have "\\(length ms) * ord_of_nat m \ elts (\\\)" + using Ord_ord_of_nat oexp_mono_le omega_nonzero ord_of_nat_le_omega by blast + with Cons show ?case + by (auto simp: mult_succ OrdmemD oexp_less indecomposableD indecomposable_\_power) +qed + +lemma omega_sum_aux_less: "omega_sum_aux k ms < \ \ k" +proof (induction rule: omega_sum_aux.induct) + case (3 n m ms) + have " \\n * ord_of_nat m + \\n < \\n * \" + by (metis Ord_ord_of_nat \_power_succ_gtr mult_succ oexp_succ ord_of_nat.simps(2)) + with 3 show ?case + using dual_order.strict_trans by force +qed auto + +lemma omega_sum_less: "omega_sum ms < \ \ (length ms)" + by (rule omega_sum_aux_less) + +lemma omega_sum_ge: "m \ 0 \ \ \ (length ms) \ omega_sum (m#ms)" + apply clarsimp + by (metis Ord_ord_of_nat add_le_cancel_left0 le_mult Nat.neq0_conv ord_of_eq_0_iff vsubsetD) + +lemma omega_sum_length_less: + assumes "length ms < length ns" "normal ns" + shows "omega_sum ms < omega_sum ns" +proof (cases ns) + case Nil + then show ?thesis + using assms by auto +next + case (Cons n ns') + have "\ \ length ms \ \ \ length ns'" + using assms local.Cons by (simp add: oexp_mono_le) + then have "\ omega_sum (n#ns') \ omega_sum ms" + using omega_sum_ge [of n ns'] omega_sum_less [of ms] \normal ns\ local.Cons by auto + then show ?thesis + by (metis Ord_linear2 Ord_omega_sum local.Cons) +qed + +lemma omega_sum_length_leD: + assumes "omega_sum ms \ omega_sum ns" "normal ms" + shows "length ms \ length ns" + by (meson assms leD leI omega_sum_length_less) + + +lemma omega_sum_less_eqlen_iff_cases [simp]: + assumes "length ms = length ns" + shows "omega_sum (m#ms) < omega_sum (n#ns) + \ m m=n \ omega_sum ms < omega_sum ns" + (is "?lhs = ?rhs") +proof + assume L: ?lhs + have "\ Suc n < Suc m" + using omega_sum_less [of ms] omega_sum_less [of ns] L assms mult_nat_less_add_less by fastforce + then have "m\n" + by auto + with L assms show ?rhs + by auto +next + assume ?rhs + then show ?lhs + by (auto simp: mult_nat_less_add_less omega_sum_aux_less assms) +qed + +lemma omega_sum_lex_less_iff_cases: + "((length ms, omega_sum (m#ms)), (length ns, omega_sum (n#ns))) \ less_than <*lex*> VWF + \ length ms < length ns + \ length ms = length ns \ m m=n \ ((length ms, omega_sum ms), (length ns, omega_sum ns)) \ less_than <*lex*> VWF" + using omega_sum_less_eqlen_iff_cases by force + +lemma omega_sum_less_iff_cases: + assumes "m > 0" "n > 0" + shows "omega_sum (m#ms) < omega_sum (n#ns) + \ length ms < length ns + \ length ms = length ns \ m length ms = length ns \ m=n \ omega_sum ms < omega_sum ns" + (is "?lhs = ?rhs") +proof + assume L: ?lhs + then have "length ms \ length ns" + using omega_sum_length_leD [OF less_imp_le [OF L]] by (simp add: \m > 0\) + moreover have "m\n" if "length ms = length ns" + using L omega_sum_less_eqlen_iff_cases that by auto + ultimately show ?rhs + using L by auto +next + assume ?rhs + moreover + have "omega_sum (m # ms) < omega_sum (n # ns)" + if "length ms < length ns" + using that by (metis Suc_mono \n > 0\ length_Cons normal_Suc omega_sum_length_less) + ultimately show ?lhs + using omega_sum_less_eqlen_iff_cases by force +qed + +lemma omega_sum_less_iff: + "((length ms, omega_sum ms), (length ns, omega_sum ns)) \ less_than <*lex*> VWF + \ (ms,ns) \ lenlex less_than" +proof (induction ms arbitrary: ns) + case Nil + then show ?case + by auto +next + case (Cons m ms) + then show ?case + proof (induction ns) + case (Cons n ns') + show ?case + using omega_sum_lex_less_iff_cases [of ms m ns' n] Cons.prems + by (simp add: Cons_lenlex_iff lenlex_length order.not_eq_order_implies_strict nat_less_le) + qed auto +qed + +lemma eq_omega_sum_less_iff: + assumes "length ms = length ns" + shows "(omega_sum ms, omega_sum ns) \ VWF \ (ms,ns) \ lenlex less_than" + by (metis assms in_lex_prod less_not_refl less_than_iff omega_sum_less_iff) + +lemma eq_omega_sum_eq_iff: + assumes "length ms = length ns" + shows "omega_sum ms = omega_sum ns \ ms=ns" +proof + assume "omega_sum ms = omega_sum ns" + then have "(omega_sum ms, omega_sum ns) \ VWF" "(omega_sum ns, omega_sum ms) \ VWF" + by auto + then obtain "(ms,ns) \ lenlex less_than" "(ns,ms) \ lenlex less_than" + using assms eq_omega_sum_less_iff by metis + moreover have "total (lenlex less_than)" + by (simp add: total_lenlex total_less_than) + ultimately show "ms=ns" + by (meson UNIV_I total_on_def) +qed auto + +lemma inj_omega_sum: "inj_on omega_sum {l. length l = n}" + unfolding inj_on_def using eq_omega_sum_eq_iff by fastforce + +lemma Ex_omega_sum: "\ \ elts (\\n) \ \ns. \ = omega_sum ns \ length ns = n" +proof (induction n arbitrary: \) + case 0 + then show ?case + by (rule_tac x="[]" in exI) auto +next + case (Suc n) + then obtain k::nat where k: "\ \ elts (\ \ n * k)" + and kmin: "\k'. k' \ \ elts (\ \ n * k')" + by (metis Ord_ord_of_nat elts_mult_\E oexp_succ ord_of_nat.simps(2)) + show ?case + proof (cases k) + case (Suc k') + then obtain \ where \: "\ = (\ \ n * k') + \" + by (metis lessI mult_succ ord_of_nat.simps(2) k kmin mem_plus_V_E) + then have \in: "\ \ elts (\ \ n)" + using Suc k mult_succ by auto + then obtain ns where ns: "\ = omega_sum ns" and len: "length ns = n" + using Suc.IH by auto + moreover have "omega_sum ns < \\n" + using OrdmemD ns \in by auto + ultimately show ?thesis + by (rule_tac x="k'#ns" in exI) (simp add: \) + qed (use k in auto) +qed + +lemma omega_sum_drop [simp]: "omega_sum (dropWhile (\n. n=0) ns) = omega_sum ns" + by (induction ns) auto + +lemma normal_drop [simp]: "normal (dropWhile (\n. n=0) ns)" + by (induction ns) auto + +lemma omega_sum_\\: + assumes "\ \ elts (\\\)" + obtains ns where "\ = omega_sum ns" "normal ns" +proof - + obtain ms where "\ = omega_sum ms" + using assms Ex_omega_sum by (auto simp: oexp_Limit elts_\) + show thesis + proof + show "\ = omega_sum (dropWhile (\n. n=0) ms)" + by (simp add: \\ = omega_sum ms\) + show "normal (dropWhile (\n. n=0) ms)" + by auto + qed +qed + +definition Cantor_\\ :: "V \ nat list" + where "Cantor_\\ \ \x. @ns. x = omega_sum ns \ normal ns" + +lemma + assumes "\ \ elts (\\\)" + shows Cantor_\\: "omega_sum (Cantor_\\ \) = \" + and normal_Cantor_\\: "normal (Cantor_\\ \)" + by (metis (mono_tags, lifting) Cantor_\\_def assms omega_sum_\\ someI)+ + + +subsection \Larson's set $W(n)$\ + +definition WW :: "nat list set" + where "WW \ {l. strict_sorted l}" + +fun into_WW :: "nat \ nat list \ nat list" where + "into_WW k [] = []" +| "into_WW k (n#ns) = (k+n) # into_WW (Suc (k+n)) ns" + +fun from_WW :: "nat \ nat list \ nat list" where + "from_WW k [] = []" +| "from_WW k (n#ns) = (n - k) # from_WW (Suc n) ns" + +lemma from_into_WW [simp]: "from_WW k (into_WW k ns) = ns" + by (induction ns arbitrary: k) auto + +lemma inj_into_WW: "inj (into_WW k)" + by (metis from_into_WW injI) + +lemma into_from_WW_aux: + "\strict_sorted ns; \n\list.set ns. k \ n\ \ into_WW k (from_WW k ns) = ns" + by (induction ns arbitrary: k) (auto simp: Suc_leI) + +lemma into_from_WW [simp]: "strict_sorted ns \ into_WW 0 (from_WW 0 ns) = ns" + by (simp add: into_from_WW_aux) + +lemma into_WW_imp_ge: "y \ List.set (into_WW x ns) \ x \ y" + by (induction ns arbitrary: x) fastforce+ + +lemma strict_sorted_into_WW: "strict_sorted (into_WW x ns)" + by (induction ns arbitrary: x) (auto simp: dest: into_WW_imp_ge) + +lemma length_into_WW: "length (into_WW x ns) = length ns" + by (induction ns arbitrary: x) auto + +lemma WW_eq_range_into: "WW = range (into_WW 0)" + by (metis (mono_tags, hide_lams) WW_def equalityI image_subset_iff into_from_WW mem_Collect_eq rangeI strict_sorted_into_WW subset_iff) + +lemma into_WW_lenlex_iff: "(into_WW k ms, into_WW k ns) \ lenlex less_than \ (ms, ns) \ lenlex less_than" +proof (induction ms arbitrary: ns k) + case Nil + then show ?case + by simp (metis length_0_conv length_into_WW) +next + case (Cons m ms) + then show ?case + by (induction ns) (auto simp: Cons_lenlex_iff length_into_WW) +qed + +lemma wf_llt [simp]: "wf (lenlex less_than)" + by blast + +lemma trans_llt [simp]: "trans (lenlex less_than)" + by blast + +lemma total_llt [simp]: "total_on A (lenlex less_than)" + by (meson UNIV_I total_lenlex total_less_than total_on_def) + +lemma omega_sum_1_less: + assumes "(ms,ns) \ lenlex less_than" shows "omega_sum (1#ms) < omega_sum (1#ns)" +proof - + have "omega_sum (1#ms) < omega_sum (1#ns)" if "length ms < length ns" + using omega_sum_less_iff_cases that zero_less_one by blast + then show ?thesis + using assms by (auto simp: mult_succ simp flip: omega_sum_less_iff) +qed + +lemma ordertype_WW_1: "ordertype WW (lenlex less_than) \ ordertype UNIV (lenlex less_than)" + by (rule ordertype_mono) auto + +lemma ordertype_WW_2: "ordertype UNIV (lenlex less_than) \ \\\" +proof (rule ordertype_inc_le_Ord) + show "range (\ms. omega_sum (1#ms)) \ elts (\\\)" + by (meson Ord_\ Ord_mem_iff_lt Ord_oexp Ord_omega_sum image_subset_iff omega_sum_less_\\) +qed (use omega_sum_1_less in auto) + +lemma ordertype_WW_3: "\\\ \ ordertype WW (lenlex less_than)" +proof - + define \ where "\ \ into_WW 0 \ Cantor_\\" + have \\: "\\\ = tp (elts (\\\))" + by simp + also have "\ \ ordertype WW (lenlex less_than)" + proof (rule ordertype_inc_le) + fix \ \ + assume \: "\ \ elts (\\\)" and \: "\ \ elts (\\\)" and "(\, \) \ VWF" + then obtain *: "Ord \" "Ord \" "\<\" + by (metis Ord_in_Ord Ord_ordertype VWF_iff_Ord_less \\) + then have "length (Cantor_\\ \) \ length (Cantor_\\ \)" + using \ \ by (simp add: Cantor_\\ normal_Cantor_\\ omega_sum_length_leD) + with \ \ * have "(Cantor_\\ \, Cantor_\\ \) \ lenlex less_than" + by (auto simp: Cantor_\\ simp flip: omega_sum_less_iff) + then show "(\ \, \ \) \ lenlex less_than" + by (simp add: \_def into_WW_lenlex_iff) + next + show "\ ` elts (\\\) \ WW" + by (auto simp: \_def WW_def strict_sorted_into_WW) + qed auto + finally show "\\\ \ ordertype WW (lenlex less_than)" . +qed + +lemma ordertype_WW: "ordertype WW (lenlex less_than) = \\\" + and ordertype_UNIV_\\: "ordertype UNIV (lenlex less_than) = \\\" + using ordertype_WW_1 ordertype_WW_2 ordertype_WW_3 by auto + + +lemma ordertype_\\: + fixes F :: "nat \ nat list set" + assumes "\j::nat. ordertype (F j) (lenlex less_than) = \\j" + shows "ordertype (\j. F j) (lenlex less_than) = \\\" +proof (rule antisym) + show "ordertype (\ (range F)) (lenlex less_than) \ \ \ \" + by (metis ordertype_UNIV_\\ ordertype_mono small top_greatest trans_llt wf_llt) + have "\n. \ \ ord_of_nat n \ ordertype (\ (range F)) (lenlex less_than)" + by (metis TC_small Union_upper assms ordertype_mono rangeI trans_llt wf_llt) + then show "\ \ \ \ ordertype (\ (range F)) (lenlex less_than)" + by (auto simp: oexp_\_Limit ZFC_in_HOL.SUP_le_iff elts_\) +qed + + + +definition WW_seg :: "nat \ nat list set" + where "WW_seg n \ {l \ WW. length l = n}" + +lemma WW_seg_subset_WW: "WW_seg n \ WW" + by (auto simp: WW_seg_def) + +lemma WW_eq_UN_WW_seg: "WW = (\ n. WW_seg n)" + by (auto simp: WW_seg_def) + +lemma ordertype_list_seg: "ordertype {l. length l = n} (lenlex less_than) = \\n" +proof - + have "bij_betw omega_sum {l. length l = n} (elts (\\n))" + unfolding WW_seg_def bij_betw_def + by (auto simp: inj_omega_sum Ord_mem_iff_lt omega_sum_less dest: Ex_omega_sum) + then show ?thesis + by (force simp: ordertype_eq_iff simp flip: eq_omega_sum_less_iff) +qed + +lemma ordertype_WW_seg: "ordertype (WW_seg n) (lenlex less_than) = \\n" + (is "ordertype ?W ?R = \\n") +proof - + have "ordertype {l. length l = n} ?R = ordertype ?W ?R" + proof (subst ordertype_eq_ordertype) + show "\f. bij_betw f {l. length l = n} ?W \ (\x\{l. length l = n}. \y\{l. length l = n}. ((f x, f y) \ lenlex less_than) = ((x, y) \ lenlex less_than))" + proof (intro exI conjI) + have "inj_on (into_WW 0) {l. length l = n}" + by (metis from_into_WW inj_onI) + then show "bij_betw (into_WW 0) {l. length l = n} ?W" + by (auto simp: bij_betw_def WW_seg_def WW_eq_range_into length_into_WW) + qed (simp add: into_WW_lenlex_iff) + qed auto + then show ?thesis + using ordertype_list_seg by auto +qed + + +subsection \Definitions required for the lemmas\ + +subsubsection \Larson's "$<$"-relation on ordered lists\ + +instantiation list :: (ord)ord +begin + +definition "xs < ys \ xs \ [] \ ys \ [] \ last xs < hd ys" for xs ys :: "'a list" +definition "xs \ ys \ xs < ys \ xs = ys" for xs ys :: "'a list" + +instance + by standard + +end + +lemma less_Nil [simp]: "xs < []" "[] < xs" + by (auto simp: less_list_def) + +lemma less_sets_imp_list_less: + assumes "less_sets (list.set xs) (list.set ys)" + shows "xs < ys" + by (metis assms last_in_set less_list_def less_sets_def list.set_sel(1)) + +lemma less_sets_imp_sorted_list_of_set: + assumes "less_sets A B" "finite A" "finite B" + shows "list_of A < list_of B" + by (simp add: assms less_sets_imp_list_less) + +lemma sorted_list_of_set_imp_less_sets: + assumes "xs < ys" "sorted xs" "sorted ys" + shows "less_sets (list.set xs) (list.set ys)" + using assms sorted_hd_le sorted_le_last + by (force simp: less_list_def less_sets_def intro: order.trans) + +lemma less_list_iff_less_sets: + assumes "sorted xs" "sorted ys" + shows "xs < ys \ less_sets (list.set xs) (list.set ys)" + using assms sorted_hd_le sorted_le_last + by (force simp: less_list_def less_sets_def intro: order.trans) + +lemma sorted_trans: + assumes "xs < ys" "ys < zs" "sorted ys" "ys \ []" shows "xs < zs" + using assms unfolding less_list_def + by (metis dual_order.strict_trans last_in_set leD neqE sorted_hd_le) + +lemma strict_sorted_imp_append_less: + assumes "strict_sorted (xs @ ys)" + shows "xs < ys" + using assms by (simp add: less_list_def sorted_wrt_append strict_sorted_sorted_wrt) + +lemma strict_sorted_append_iff: + "strict_sorted (xs @ ys) \ xs < ys \ strict_sorted xs \ strict_sorted ys" (is "?lhs = ?rhs") +proof + assume ?lhs then show ?rhs + by (auto simp: sorted_wrt_append strict_sorted_sorted_wrt less_list_def) +next + assume R: ?rhs + then have "\x y. \x \ list.set xs; y \ list.set ys\ \ x < y" + using less_setsD sorted_list_of_set_imp_less_sets strict_sorted_imp_sorted by blast + with R show ?lhs + by (auto simp: sorted_wrt_append strict_sorted_sorted_wrt) +qed + +lemma singleton_less_list_iff: "sorted xs \ [n] < xs \ {..n} \ list.set xs = {}" + apply (simp add: less_list_def set_eq_iff) + by (metis empty_iff less_le_trans list.set(1) list.set_sel(1) not_le sorted_hd_le) + +lemma less_last_iff: "xs@[x] < ys \ [x] < ys" + by (simp add: less_list_def) + +lemma less_Cons_iff: "NO_MATCH [] ys \ xs < y#ys \ xs < [y]" + by (simp add: less_list_def) + +lemma less_hd_imp_less: "xs < [hd ys] \ xs < ys" + by (simp add: less_list_def) + +lemma last_less_imp_less: "[last xs] < ys \ xs < ys" + by (simp add: less_list_def) + +lemma strict_sorted_concat_I: + assumes + "\x. x \ list.set xs \ strict_sorted x" + "\n. Suc n < length xs \ xs!n < xs!Suc n" + assumes "xs \ lists (- {[]})" + shows "strict_sorted (concat xs)" + using assms +proof (induction xs) + case (Cons x xs) + then have "x < concat xs" + apply (simp add: less_list_def) + by (metis Compl_iff hd_concat insertI1 length_greater_0_conv length_pos_if_in_set list.sel(1) lists.cases nth_Cons_0) + with Cons show ?case + by (force simp: strict_sorted_append_iff) +qed auto + + +subsection \Nash Williams for lists\ + +subsubsection \Thin sets of lists\ + +inductive initial_segment :: "'a list \ 'a list \ bool" + where "initial_segment xs (xs@ys)" + +definition thin where "thin A \ \ (\x y. x \ A \ y \ A \ x \ y \ initial_segment x y)" + +lemma initial_segment_ne: + assumes "initial_segment xs ys" "xs \ []" + shows "ys \ [] \ hd ys = hd xs" + using assms by (auto elim!: initial_segment.cases) + +lemma take_initial_segment: + assumes "initial_segment xs ys" "k \ length xs" + shows "take k xs = take k ys" + by (metis append_eq_conv_conj assms initial_segment.cases min_def take_take) + +lemma initial_segment_length_eq: + assumes "initial_segment xs ys" "length xs = length ys" + shows "xs = ys" + using assms initial_segment.cases by fastforce + +lemma initial_segment_Nil [simp]: "initial_segment [] ys" + by (simp add: initial_segment.simps) + +lemma initial_segment_Cons [simp]: "initial_segment (x#xs) (y#ys) \ x=y \ initial_segment xs ys" + by (metis append_Cons initial_segment.simps list.inject) + +lemma init_segment_iff_initial_segment: + assumes "strict_sorted xs" "strict_sorted ys" + shows "init_segment (list.set xs) (list.set ys) \ initial_segment xs ys" (is "?lhs = ?rhs") +proof + assume ?lhs + then obtain S' where S': "list.set ys = list.set xs \ S'" "less_sets (list.set xs) S'" + by (auto simp: init_segment_def) + then have "finite S'" + by (metis List.finite_set finite_Un) + have "ys = xs @ list_of S'" + using S' \strict_sorted xs\ + proof (induction xs) + case Nil + with \strict_sorted ys\ show ?case + by auto + next + case (Cons a xs) + with \finite S'\ have "ys = a # xs @ list_of S'" + by (metis List.finite_set \finite S'\ append_Cons assms(2) sorted_list_of_set_Un sorted_list_of_set_set_of) + then show ?case + by (auto simp: Cons) + qed + then show ?rhs + using initial_segment.intros by blast +next + assume ?rhs + then show ?lhs + proof cases + case (1 ys) + with assms(2) show ?thesis + using sorted_list_of_set_imp_less_sets strict_sorted_imp_sorted + by (auto simp: init_segment_def strict_sorted_append_iff) + qed +qed + +theorem Nash_Williams_WW: + fixes h :: "nat list \ nat" + assumes "infinite M" and h: "h ` {l \ A. List.set l \ M} \ {..<2}" and "thin A" "A \ WW" + obtains i N where "i < 2" "infinite N" "N \ M" "h ` {l \ A. List.set l \ N} \ {i}" +proof - + define AM where "AM \ {l \ A. List.set l \ M}" + have "thin_set (list.set ` A)" + using \thin A\ \A \ WW\ unfolding thin_def thin_set_def WW_def + by (auto simp: subset_iff init_segment_iff_initial_segment) + then have "thin_set (list.set ` AM)" + by (simp add: AM_def image_subset_iff thin_set_def) + then have "Ramsey (list.set ` AM) 2" + using Nash_Williams_2 by metis + moreover have "(h \ list_of) ` list.set ` AM \ {..<2}" + unfolding AM_def + proof clarsimp + fix l + assume "l \ A" "list.set l \ M" + then have "strict_sorted l" + using WW_def \A \ WW\ by blast + then show "h (list_of (list.set l)) < 2" + using h \l \ A\ \list.set l \ M\ by auto + qed + ultimately obtain N i where N: "N \ M" "infinite N" "i<2" + and "\j. \j<2; i\j\ \ (h \ list_of) -` {j} \ (list.set ` AM) \ Pow N = {}" + unfolding Ramsey_def by (metis \infinite M\) + then have N_disjoint: "(h \ list_of) -` {1-i} \ (list.set ` AM) \ Pow N = {}" + by (metis One_nat_def diff_less_Suc not_less_eq numeral_2_eq_2 zero_less_diff) + have "h ` {l \ A. list.set l \ N} \ {i}" + proof clarify + fix l + assume "l \ A" and "list.set l \ N" + then have "h l < 2" + using h \N \ M\ by force + with \i<2\ have "h l \ Suc 0 - i \ h l = i" + by (auto simp: eval_nat_numeral less_Suc_eq) + moreover have "strict_sorted l" + using \A \ WW\ \l \ A\ unfolding WW_def by blast + moreover have "h (list_of (list.set l)) = 1 - i \ \ (list.set l \ N)" + using N_disjoint \N \ M\ \l \ A\ by (auto simp: AM_def) + ultimately + show "h l = i" + using N \N \ M\ \l \ A\ \list.set l \ N\ + by (auto simp: vimage_def set_eq_iff AM_def WW_def subset_iff) + qed + then show thesis + using that \i<2\ N by auto +qed + +subsection \Specialised functions on lists\ + +lemma mem_lists_non_Nil: "xss \ lists (- {[]}) \ (\x \ list.set xss. x \ [])" + by auto + +fun acc_lengths :: "nat \ 'a list list \ nat list" + where "acc_lengths acc [] = []" + | "acc_lengths acc (l#ls) = (acc + length l) # acc_lengths (acc + length l) ls" + +lemma length_acc_lengths [simp]: "length (acc_lengths acc ls) = length ls" + by (induction ls arbitrary: acc) auto + +lemma acc_lengths_eq_Nil_iff [simp]: "acc_lengths acc ls = [] \ ls = []" + by (metis length_0_conv length_acc_lengths) + +lemma set_acc_lengths: + assumes "ls \ lists (- {[]})" shows "list.set (acc_lengths acc ls) \ {acc<..}" + using assms by (induction ls rule: acc_lengths.induct) fastforce+ + +lemma hd_acc_lengths [simp]: "hd (acc_lengths acc (l#ls)) = acc + length l" + by simp + +lemma last_acc_lengths [simp]: + "ls \ [] \ last (acc_lengths acc ls) = acc + sum_list (map length ls)" +by (induction acc ls rule: acc_lengths.induct) auto + +lemma nth_acc_lengths [simp]: + "\ls \ []; k < length ls\ \ acc_lengths acc ls ! k = acc + sum_list (map length (take (Suc k) ls))" + by (induction acc ls arbitrary: k rule: acc_lengths.induct) (fastforce simp: less_Suc_eq nth_Cons')+ + +lemma acc_lengths_plus: "acc_lengths (m+n) as = map ((+)m) (acc_lengths n as)" + by (induction n as arbitrary: m rule: acc_lengths.induct) (auto simp: add.assoc) + +lemma acc_lengths_shift: "NO_MATCH 0 acc \ acc_lengths acc as = map ((+)acc) (acc_lengths 0 as)" + by (metis acc_lengths_plus add.comm_neutral) + +lemma length_concat_acc_lengths: + "ls \ [] \ k + length (concat ls) \ list.set (acc_lengths k ls)" + by (metis acc_lengths_eq_Nil_iff last_acc_lengths last_in_set length_concat) + +lemma strict_sorted_acc_lengths: + assumes "ls \ lists (- {[]})" shows "strict_sorted (acc_lengths acc ls)" + using assms +proof (induction ls rule: acc_lengths.induct) + case (2 acc l ls) + then have "strict_sorted (acc_lengths (acc + length l) ls)" + using "2" by auto + then show ?case + using set_acc_lengths "2.prems" by auto +qed auto + +lemma acc_lengths_append: + "acc_lengths acc (xs @ ys) + = acc_lengths acc xs @ acc_lengths (acc + sum_list (map length xs)) ys" +by (induction acc xs rule: acc_lengths.induct) (auto simp: add.assoc) + + +declare acc_lengths.simps [simp del] + +lemma length_concat_ge: + assumes "as \ lists (- {[]})" + shows "length (concat as) \ length as" + using assms +proof (induction as) + case (Cons a as) + then have "length a \ Suc 0" "\l. l \ list.set as \ length l \ Suc 0" + by (auto simp: Suc_leI) + then show ?case + using Cons.IH by force +qed auto + + +fun interact :: "'a list list \ 'a list list \ 'a list" + where + "interact [] ys = concat ys" +| "interact xs [] = concat xs" +| "interact (x#xs) (y#ys) = x @ y @ interact xs ys" + +lemma (in monoid_add) length_interact: + "length (interact xs ys) = sum_list (map length xs) + sum_list (map length ys)" + by (induction rule: interact.induct) (auto simp: length_concat) + +lemma length_interact_ge: + assumes "xs \ lists (- {[]})" "ys \ lists (- {[]})" + shows "length (interact xs ys) \ length xs + length ys" + by (metis mem_lists_non_Nil add_mono assms length_concat length_concat_ge length_interact) + +lemma set_interact [simp]: + shows "list.set (interact xs ys) = list.set (concat xs) \ list.set (concat ys)" +by (induction rule: interact.induct) auto + +lemma interact_eq_Nil_iff [simp]: + assumes "xs \ lists (- {[]})" "ys \ lists (- {[]})" + shows "interact xs ys = [] \ xs=[] \ ys=[]" + using length_interact_ge [OF assms] by fastforce + +lemma interact_sing [simp]: "interact [x] ys = x @ concat ys" + by (metis (no_types) concat.simps(2) interact.simps neq_Nil_conv) + +lemma hd_interact: "\xs \ []; hd xs \ []\ \ hd (interact xs ys) = hd (hd xs)" + by (metis concat.simps(2) hd_append2 interact.simps(2) interact.simps(3) list.exhaust list.sel(1)) + +lemma acc_lengths_concat_injective: + assumes "concat as' = concat as" "acc_lengths n as' = acc_lengths n as" + shows "as' = as" + using assms +proof (induction as arbitrary: n as') + case Nil + then show ?case + by (metis acc_lengths_eq_Nil_iff) +next + case (Cons a as) + then obtain a' bs where "as' = a'#bs" + by (metis Suc_length_conv length_acc_lengths) + with Cons show ?case + by (simp add: acc_lengths.simps) +qed + +lemma acc_lengths_interact_injective: + assumes "interact as' bs' = interact as bs" "acc_lengths a as' = acc_lengths a as" "acc_lengths b bs' = acc_lengths b bs" + shows "as' = as \ bs' = bs" + using assms +proof (induction as bs arbitrary: a b as' bs' rule: interact.induct) + case (1 cs) + then have "as' = []" + by (metis acc_lengths_eq_Nil_iff) + with 1 show ?case + using acc_lengths_concat_injective by auto +next + case (2 c cs) + then show ?case + by (metis acc_lengths_concat_injective acc_lengths_eq_Nil_iff interact.simps(2) list.exhaust) +next + case (3 x xs y ys) + then obtain a' us b' vs where "as' = a'#us" "bs' = b'#vs" + by (metis length_Suc_conv length_acc_lengths) + with 3 show ?case + by (auto simp: acc_lengths.simps) +qed + + +lemma strict_sorted_interact_I: + assumes "length ys \ length xs" "length xs \ Suc (length ys)" + "\x. x \ list.set xs \ strict_sorted x" + "\y. y \ list.set ys \ strict_sorted y" + "\n. n < length ys \ xs!n < ys!n" + "\n. Suc n < length xs \ ys!n < xs!Suc n" + assumes "xs \ lists (- {[]})" "ys \ lists (- {[]})" + shows "strict_sorted (interact xs ys)" + using assms +proof (induction rule: interact.induct) + case (3 x xs y ys) + then have "x < y" + by force+ + moreover have "strict_sorted (interact xs ys)" + using 3 by simp (metis Suc_less_eq nth_Cons_Suc) + moreover have "y < interact xs ys" + proof (clarsimp simp add: less_list_def) + assume "y \ []" and ne: "interact xs ys \ []" + then show "last y < hd (interact xs ys)" + using 3 + apply simp + by (metis dual_order.strict_trans1 hd_interact length_greater_0_conv less_list_def list.sel(1) lists.simps mem_lists_non_Nil nth_Cons' nth_mem) + qed + ultimately show ?case + using 3 by (simp add: strict_sorted_append_iff less_list_def) +qed auto + + +subsection \Forms and interactions\ + +subsubsection \Forms\ + +inductive Form_Body :: "[nat, nat, nat list, nat list, nat list] \ bool" + where "Form_Body ka kb xs ys zs" + if "length xs < length ys" "xs = concat (a#as)" "ys = concat (b#bs)" + "a#as \ lists (- {[]})" "b#bs \ lists (- {[]})" + "length (a#as) = ka" "length (b#bs) = kb" + "c = acc_lengths 0 (a#as)" + "d = acc_lengths 0 (b#bs)" + "zs = concat [c, a, d, b] @ interact as bs" + "strict_sorted zs" + + +inductive Form :: "[nat, nat list set] \ bool" + where "Form 0 {xs,ys}" if "length xs = length ys" "xs \ ys" + | "Form (2*k-1) {xs,ys}" if "Form_Body k k xs ys zs" "k > 0" + | "Form (2*k) {xs,ys}" if "Form_Body (Suc k) k xs ys zs" "k > 0" + +inductive_cases Form_0_cases_raw: "Form 0 u" + +lemma Form_elim_upair: + assumes "Form l U" + obtains xs ys where "xs \ ys" "U = {xs,ys}" "length xs \ length ys" + using assms + by (elim Form.cases Form_Body.cases; metis dual_order.order_iff_strict less_not_refl) + + +lemma Form_Body_WW: + assumes "Form_Body ka kb xs ys zs" + shows "zs \ WW" + by (rule Form_Body.cases [OF assms]) (auto simp: WW_def) + +lemma Form_Body_nonempty: + assumes "Form_Body ka kb xs ys zs" + shows "length zs > 0" + by (rule Form_Body.cases [OF assms]) auto + +lemma Form_Body_length: + assumes "Form_Body ka kb xs ys zs" + shows "length xs < length ys" + using Form_Body.cases assms by blast + +lemma form_cases: + fixes l::nat + obtains (zero) "l = 0" | (odd) k where "l = 2*k-1" "k > 0" | (even) k where "l = 2*k" "k > 0" +proof - + have "l = 0 \ (\k. l = 2*k-1 \ k > 0) \ (\k. l = 2*k \ k > 0)" + by presburger + then show thesis + using even odd zero by blast +qed + +lemma odd_eq_iffs: "2 * k - Suc 0 = 2 * k' - Suc 0 \ k = k' \ k=0 \ k'=0" + "2 * k - Suc 0 = 2 * k' \ k=0 \ k'=0" + "2 * k = 2 * k' - Suc 0 \ k=0 \ k'=0" + by presburger+ + +subsubsection \Interactions\ + +lemma interact: + assumes "Form l U" "l>0" + obtains k xs ys zs where "l = 2*k-1" "U = {xs,ys}" "Form_Body k k xs ys zs" "k > 0" + | k xs ys zs where "l = 2*k" "U = {xs,ys}" "Form_Body (Suc k) k xs ys zs" "k > 0" + by (rule Form.cases [OF \Form l U\]) (use \l>0\ in \force+\) + + +definition inter_scheme :: "nat \ nat list set \ nat list" + where "inter_scheme l U \ @zs. \k xs ys. l > 0 + \ (l = 2*k-1 \ U = {xs,ys} \ Form_Body k k xs ys zs + \ l = 2*k \ U = {xs,ys} \ Form_Body (Suc k) k xs ys zs)" + + +lemma inter_scheme: + assumes "Form l U" "l>0" + obtains (odd) k xs ys where "l = 2*k-1" "U = {xs,ys}" "Form_Body k k xs ys (inter_scheme l U)" + | (even) k xs ys where "l = 2*k" "U = {xs,ys}" "Form_Body (Suc k) k xs ys (inter_scheme l U)" + using form_cases [of l] +proof cases + case zero + with \l > 0\ show ?thesis + by auto +next + case (odd k) + show ?thesis + using interact [OF assms] + proof cases + case (1 k' xs ys zs) + show ?thesis + proof (rule that(1)) + have "\ Form_Body k k ys xs zs" for zs + using 1 Form_Body_length less_asym' by blast + then show "Form_Body k k xs ys (inter_scheme l U)" + using odd 1 + by (force simp: Set.doubleton_eq_iff odd_eq_iffs inter_scheme_def conj_disj_distribR ex_disj_distrib some_eq_ex) + qed (use 1 odd in auto) + qed (use odd in presburger) +next + case (even k) + show ?thesis + using interact [OF assms] + proof cases + case (2 k' xs ys zs) + show ?thesis + proof (rule that(2)) + have "\ Form_Body (Suc k) k ys xs zs" for zs + using 2 Form_Body_length less_asym' by blast + then show "Form_Body (Suc k) k xs ys (inter_scheme l U)" + using even 2 + by (force simp: Set.doubleton_eq_iff odd_eq_iffs inter_scheme_def conj_disj_distribR ex_disj_distrib some_eq_ex) + qed (use 2 even in auto) + qed (use even in presburger) +qed + + +lemma inter_scheme_simple: + assumes "Form k U" "k>0" + shows "inter_scheme k U \ WW \ length (inter_scheme k U) > 0" + using inter_scheme by (meson Form_Body_WW Form_Body_nonempty assms) + +lemma inter_scheme_strict_sorted: + assumes "Form k U" "k>0" + shows "strict_sorted (inter_scheme k U)" + using inter_scheme_simple [OF assms] by (auto simp: WW_def) + +subsubsection \Injectivity of interactions\ + +proposition inter_scheme_injective: + assumes "Form l U" "Form l U'" "l > 0" and eq: "inter_scheme l U' = inter_scheme l U" + shows "U' = U" + using inter_scheme [OF \Form l U\ \l>0\] +proof cases + case (1 k xs ys) + then obtain a as b bs c d + where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)" + and len: "length (a#as) = k" "length (b#bs) = k" + and c: "c = acc_lengths 0 (a#as)" + and d: "d = acc_lengths 0 (b#bs)" + and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs" + using Form_Body.simps by auto + note one = 1 + show ?thesis + using inter_scheme [OF \Form l U'\ \l>0\] + proof cases + case (1 k' xs' ys') + then obtain a' as' b' bs' c' d' + where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')" + and len': "length (a'#as') = k'" "length (b'#bs') = k'" + and c': "c' = acc_lengths 0 (a'#as')" + and d': "d' = acc_lengths 0 (b'#bs')" + and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'" + using Form_Body.simps by auto + have [simp]: "k' = k" + using 1 one \l>0\ by (simp add: odd_eq_iffs) + have [simp]: "length c = length c'" "length d = length d'" + using c c' d d' len' len by auto + have c_off: "c' = c" "a' @ d' @ b' @ interact as' bs' = a @ d @ b @ interact as bs" + using eq by (auto simp: Ueq Ueq') + then have len_a: "length a' = length a" + by (metis acc_lengths.simps(2) add.left_neutral c c' nth_Cons_0) + with c_off have \
: "a' = a" "d' = d" "b' @ interact as' bs' = b @ interact as bs" + by auto + then have "length (interact as' bs') = length (interact as bs)" + by (metis acc_lengths.simps(2) add_left_cancel append_eq_append_conv d d' list.inject) + with \
have "b' = b" "interact as' bs' = interact as bs" + by auto + moreover have "acc_lengths 0 as' = acc_lengths 0 as" + using \a' = a\ \c' = c\ by (simp add: c' c acc_lengths.simps acc_lengths_shift) + moreover have "acc_lengths 0 bs' = acc_lengths 0 bs" + using \b' = b\ \d' = d\ by (simp add: d' d acc_lengths.simps acc_lengths_shift) + ultimately have "as' = as \ bs' = bs" + using acc_lengths_interact_injective by blast + with one 1 show ?thesis + by (simp add: xs ys xs' ys' \a' = a\ \b' = b\) + next + case (2 k' xs' ys') + then show ?thesis + using 1 \l>0\ by (simp add: odd_eq_iffs) + qed +next + case (2 k xs ys) + then obtain a as b bs c d + where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)" + and len: "length (a#as) = Suc k" "length (b#bs) = k" + and c: "c = acc_lengths 0 (a#as)" + and d: "d = acc_lengths 0 (b#bs)" + and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs" + using Form_Body.simps by auto + note two = 2 + show ?thesis + using inter_scheme [OF \Form l U'\ \l>0\] + proof cases + case (1 k' xs' ys') + then show ?thesis + using 2 \l>0\ by (simp add: odd_eq_iffs) + next + case (2 k' xs' ys') + then obtain a' as' b' bs' c' d' + where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')" + and len': "length (a'#as') = Suc k'" "length (b'#bs') = k'" + and c': "c' = acc_lengths 0 (a'#as')" + and d': "d' = acc_lengths 0 (b'#bs')" + and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'" + using Form_Body.simps by auto + have [simp]: "k' = k" + using 2 two \l>0\ by (simp add: odd_eq_iffs) + have [simp]: "length c = length c'" "length d = length d'" + using c c' d d' len' len by auto + have c_off: "c' = c" "a' @ d' @ b' @ interact as' bs' = a @ d @ b @ interact as bs" + using eq by (auto simp: Ueq Ueq') + then have len_a: "length a' = length a" + by (metis acc_lengths.simps(2) add.left_neutral c c' nth_Cons_0) + with c_off have \
: "a' = a" "d' = d" "b' @ interact as' bs' = b @ interact as bs" + by auto + then have "length (interact as' bs') = length (interact as bs)" + by (metis acc_lengths.simps(2) add_left_cancel append_eq_append_conv d d' list.inject) + with \
have "b' = b" "interact as' bs' = interact as bs" + by auto + moreover have "acc_lengths 0 as' = acc_lengths 0 as" + using \a' = a\ \c' = c\ by (simp add: c' c acc_lengths.simps acc_lengths_shift) + moreover have "acc_lengths 0 bs' = acc_lengths 0 bs" + using \b' = b\ \d' = d\ by (simp add: d' d acc_lengths.simps acc_lengths_shift) + ultimately have "as' = as \ bs' = bs" + using acc_lengths_interact_injective by blast + with two 2 show ?thesis + by (simp add: xs ys xs' ys' \a' = a\ \b' = b\) + qed +qed + + +lemma strict_sorted_interact_imp_concat: + "strict_sorted (interact as bs) \ strict_sorted (concat as) \ strict_sorted (concat bs)" +proof (induction as bs rule: interact.induct) + case (3 x xs y ys) + show ?case + proof (cases x) + case Nil + show ?thesis + proof (cases y) + case Nil + then show ?thesis + using "3" strict_sorted_append_iff by (auto simp: \x = []\) + next + case (Cons a list) + with Nil 3 show ?thesis + apply (simp add: strict_sorted_append_iff) + by (metis (no_types, lifting) Un_iff set_interact sorted_wrt_append strict_sorted_append_iff strict_sorted_sorted_wrt) + qed + next + case (Cons a list) + have \
: "sorted_wrt (<) ((a # list) @ y @ interact xs ys)" + by (metis (no_types) "3.prems" interact.simps(3) local.Cons strict_sorted_sorted_wrt) + then have "list = [] \ concat xs = [] \ last list < hd (concat xs)" + by (metis (full_types) Un_iff hd_in_set last_ConsR last_in_set list.simps(3) set_append set_interact sorted_wrt_append) + then have "list < concat xs" + using less_list_def by blast + have "list < y" + by (metis \
append.assoc last.simps less_list_def list.distinct(1) strict_sorted_append_iff strict_sorted_sorted_wrt) + note Cons1 = Cons + show ?thesis + proof (cases y) + case Nil + then show ?thesis + using 3 by (simp add: sorted_wrt_append strict_sorted_sorted_wrt) + next + case (Cons a' list') + have "strict_sorted (list' @ concat ys)" + apply (simp add: strict_sorted_sorted_wrt) + by (metis "3.IH" "\
" Un_iff append_Cons local.Cons set_interact sorted_wrt_append strict_sorted.simps(2) strict_sorted_sorted_wrt) + moreover have "y < concat ys" + by (metis "\
" Un_iff hd_in_set last_in_set less_list_def set_interact sorted_wrt_append) + ultimately show ?thesis + using 3 \list < concat xs\ + by (auto simp: Cons1 strict_sorted_append_iff) + qed + qed +qed auto + + + + +lemma strict_sorted_interact_hd: + "\strict_sorted (interact cs ds); cs \ []; ds \ []; hd cs \ []; hd ds \ []\ + \ hd (hd cs) < hd (hd ds)" + by (metis Nil_is_append_conv hd_append2 hd_in_set interact.simps(3) list.exhaust_sel sorted_wrt_append strict_sorted_sorted_wrt) + + +text \the lengths of the two lists can differ by one\ +proposition interaction_scheme_unique_aux: + assumes eq: "concat as = concat as'" and ys': "concat bs = concat bs'" + and ne: "as \ lists (- {[]})" "bs \ lists (- {[]})" + and ss_zs: "strict_sorted (interact as bs)" + and "length bs \ length as" "length as \ Suc (length bs)" + and ne': "as' \ lists (- {[]})" "bs' \ lists (- {[]})" + and ss_zs': "strict_sorted (interact as' bs')" + and "length bs' \ length as'" "length as' \Suc (length bs')" + and "length as = length as'" "length bs = length bs'" + shows "as = as' \ bs = bs'" + using assms +proof (induction "length as" arbitrary: as bs as' bs') + case 0 then show ?case + by auto +next + case (Suc k) + show ?case + proof (cases k) + case 0 + then have "length as = Suc 0" + using Suc.hyps(2) by auto + then obtain a a' where "as = [a]" "as' = [a']" + by (metis \length as = length as'\ length_0_conv length_Suc_conv) + with 0 show ?thesis + using Suc.prems + apply (simp add: le_Suc_eq) + by (metis concat.simps length_0_conv length_Suc_conv self_append_conv) + next + case (Suc k') + then obtain a cs b ds where eq: "as = a#cs" "bs = b#ds" + using Suc.prems + by (metis Suc.hyps(2) le0 list.exhaust list.size(3) not_less_eq_eq) + have "length as' \ 0" + using Suc.hyps(2) Suc.prems(1) Suc.prems(3) interact_eq_Nil_iff by auto + then obtain a' cs' b' ds' where eq': "as' = a'#cs'" "bs' = b'#ds'" + by (metis Suc.prems(14) eq(2) length_0_conv list.exhaust) + obtain k: "k = length cs" "k \ Suc (length ds)" + using eq \Suc k = length as\ \length bs \ length as\ \length as \ Suc (length bs)\ by auto + case (Suc k') + obtain [simp]: "b \ []" "b' \ []" "a \ []" "a' \ []" + using Suc.prems by (simp add: eq eq') + then have "hd b' = hd b" + using Suc.prems(2) by (metis concat.simps(2) eq'(2) eq(2) hd_append2) + + have ss_ab: "strict_sorted (concat as)" "strict_sorted (concat bs)" + using strict_sorted_interact_imp_concat Suc.prems(5) by blast+ + have "a < b" + by (metis eq Suc.prems(5) append.assoc interact.simps(3) strict_sorted_append_iff) + have sw_ab: "sorted_wrt (<) (a @ b @ interact cs ds)" + by (metis Suc.prems(5) eq interact.simps(3) strict_sorted_sorted_wrt) + then have "hd b \ list.set (concat cs)" + by (metis Un_iff \b \ []\ list.set_sel(1) not_less_iff_gr_or_eq set_interact sorted_wrt_append) + have "b < concat cs" + using eq \strict_sorted (interact as bs)\ + apply (simp add: strict_sorted_append_iff) + by (metis Un_iff sw_ab last_in_set less_list_def list.set_sel(1) set_interact sorted_wrt_append) + have "strict_sorted (a @ concat cs)" + using eq(1) ss_ab(1) by force + then have b_cs: "strict_sorted (b @ concat cs)" + by (metis \b < concat cs\ strict_sorted_append_iff strict_sorted_sorted_wrt sw_ab) + have "list.set a = list.set (concat as) \ {..< hd b}" + proof - + have "x \ list.set a" + if "x < hd b" and "l \ list.set cs" and "x \ list.set l" for x l + using b_cs sorted_hd_le strict_sorted_imp_sorted that by fastforce + then show ?thesis + using \b \ []\ sw_ab by (force simp: strict_sorted_append_iff sorted_wrt_append eq) + qed + moreover + have ss_ab': "strict_sorted (concat as')" "strict_sorted (concat bs')" + using strict_sorted_interact_imp_concat Suc.prems(10) by blast+ + have "a' < b'" + by (metis eq' Suc.prems(10) append.assoc interact.simps(3) strict_sorted_append_iff) + have sw_ab': "sorted_wrt (<) (a' @ b' @ interact cs' ds')" + by (metis Suc.prems(10) eq' interact.simps(3) strict_sorted_sorted_wrt) + then have "hd b' \ list.set (concat cs')" + by (metis Un_iff \b' \ []\ list.set_sel(1) not_less_iff_gr_or_eq set_interact sorted_wrt_append) + have "b' < concat cs'" + using eq' \strict_sorted (interact as' bs')\ + apply (simp add: strict_sorted_append_iff) + by (metis Un_iff last_in_set less_list_def list.set_sel(1) set_interact sorted_wrt_append sw_ab') + have "strict_sorted (a' @ concat cs')" + using eq'(1) ss_ab'(1) by force + then have b_cs': "strict_sorted (b' @ concat cs')" + using \b' < concat cs'\ eq'(2) ss_ab'(2) strict_sorted_append_iff by auto + have "list.set a' = list.set (concat as') \ {..< hd b'}" + proof - + have "x \ list.set a'" + if "x < hd b'" and "l \ list.set cs'" and "x \ list.set l" for x l + using b_cs' sorted_hd_le strict_sorted_imp_sorted that by fastforce + then show ?thesis + using \b' \ []\ sw_ab' by (force simp: strict_sorted_append_iff sorted_wrt_append eq') + qed + ultimately have "a=a'" + by (metis Suc.prems(1) \hd b' = hd b\ sorted_wrt_append strict_sorted_equal strict_sorted_sorted_wrt sw_ab sw_ab') + moreover + have ccat_cs_cs': "concat cs = concat cs'" + using Suc.prems(1) \a = a'\ eq'(1) eq(1) by fastforce + have "b=b'" + proof (cases "ds = [] \ ds' = []") + case True + then show ?thesis + using Suc.prems(14) Suc.prems(2) eq'(2) eq(2) by auto + next + case False + then have "ds \ []" "ds' \ []" + by auto + have "strict_sorted b" + by (metis Suc.prems(2) concat.simps(2) eq(2) ss_ab'(2) strict_sorted_append_iff) + moreover + have "cs \ []" + using k local.Suc by auto + + then obtain "hd cs \ []" "hd ds \ []" + using Suc.prems(3) Suc.prems(4) eq list.set_sel(1) + by (simp add: \ds \ []\ mem_lists_non_Nil) + then have "concat cs \ []" + using \cs \ []\ hd_in_set by auto + have "hd (concat cs) < hd (concat ds)" + using strict_sorted_interact_hd + by (metis \cs \ []\ \ds \ []\ \hd cs \ []\ \hd ds \ []\ hd_concat strict_sorted_append_iff strict_sorted_sorted_wrt sw_ab) + then have "list.set b = list.set (concat bs) \ {..< hd (concat cs)}" + using ss_ab + apply (auto simp: strict_sorted_append_iff eq) + apply (metis \b < concat cs\ \concat cs \ []\ hd_in_set sorted_wrt_append strict_sorted_append_iff strict_sorted_sorted_wrt) + by (metis strict_sorted_iff UN_I dual_order.strict_trans2 order.asym set_concat sorted_hd_le) + moreover + have "cs' \ []" + using k local.Suc \concat cs \ []\ ccat_cs_cs' by auto + then obtain "hd cs' \ []" "hd ds' \ []" + using Suc.prems(8,9) \ds' \ []\ eq'(1) eq'(2) list.set_sel(1) by auto + then have "concat cs' \ []" + using \cs' \ []\ hd_in_set by auto + have "hd (concat cs') < hd (concat ds')" + using strict_sorted_interact_hd + by (metis \cs' \ []\ \ds' \ []\ \hd cs' \ []\ \hd ds' \ []\ hd_concat strict_sorted_append_iff strict_sorted_sorted_wrt sw_ab') + then have "list.set b' = list.set (concat bs') \ {..< hd (concat cs')}" + using ss_ab' + apply (auto simp: strict_sorted_append_iff eq') + apply (meson strict_sorted_iff \b' < concat cs'\ \b' \ []\ \concat cs' \ []\ dual_order.strict_trans2 less_list_def sorted_le_last) + by (metis strict_sorted_iff UN_I dual_order.strict_trans2 order.asym set_concat sorted_hd_le) + + ultimately show "b = b'" + by (metis Suc.prems(2) ccat_cs_cs' strict_sorted_append_iff strict_sorted_equal strict_sorted_sorted_wrt sw_ab') + qed + moreover + have "cs = cs' \ ds = ds'" + proof (rule Suc.hyps) + show "k = length cs" + using eq Suc.hyps(2) by auto[1] + show "concat ds = concat ds'" + using Suc.prems(2) \b = b'\ eq'(2) eq(2) by auto + show "strict_sorted (interact cs ds)" + using eq Suc.prems(5) strict_sorted_append_iff by auto + show "length ds \ length cs" "length cs \ Suc (length ds)" + using eq Suc.hyps(2) Suc.prems(6) k by auto + show "strict_sorted (interact cs' ds')" + using eq' Suc.prems(10) strict_sorted_append_iff by auto + show "length cs = length cs'" + using Suc.hyps(2) Suc.prems(13) eq'(1) k(1) by force + qed (use ccat_cs_cs' eq eq' Suc.prems in auto) + ultimately show ?thesis + by (simp add: \a = a'\ \b = b'\ eq eq') + qed +qed + + +proposition Form_Body_unique: + assumes "Form_Body ka kb xs ys zs" "Form_Body ka kb xs ys zs'" and "kb \ ka" "ka \ Suc kb" + shows "zs' = zs" +proof - + obtain a as b bs c d + where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)" + and ne: "a#as \ lists (- {[]})" "b#bs \ lists (- {[]})" + and len: "length (a#as) = ka" "length (b#bs) = kb" + and c: "c = acc_lengths 0 (a#as)" + and d: "d = acc_lengths 0 (b#bs)" + and Ueq: "zs = concat [c, a, d, b] @ interact as bs" + and ss_zs: "strict_sorted zs" + using Form_Body.cases [OF assms(1)] by (metis (no_types)) + obtain a' as' b' bs' c' d' + where xs': "xs = concat (a'#as')" and ys': "ys = concat (b'#bs')" + and ne': "a'#as' \ lists (- {[]})" "b'#bs' \ lists (- {[]})" + and len': "length (a'#as') = ka" "length (b'#bs') = kb" + and c': "c' = acc_lengths 0 (a'#as')" + and d': "d' = acc_lengths 0 (b'#bs')" + and Ueq': "zs' = concat [c', a', d', b'] @ interact as' bs'" + and ss_zs': "strict_sorted zs'" + using Form_Body.cases [OF assms(2)] by (metis (no_types)) + have [simp]: "length c = length c'" "length d = length d'" + using c c' d d' len' len by auto + have "a < b" + using ss_zs apply (simp add: Ueq strict_sorted_append_iff) + by (metis strict_sorted_iff append.assoc d length_0_conv length_acc_lengths list.distinct(1) strict_sorted_append_iff sorted_trans) + have "a' < b'" + using ss_zs' apply (simp add: Ueq' strict_sorted_append_iff) + by (metis strict_sorted_iff append.assoc d' length_0_conv length_acc_lengths list.distinct(1) strict_sorted_append_iff sorted_trans) + have "a#as = a'#as' \ b#bs = b'#bs'" + proof (rule interaction_scheme_unique_aux) + show "concat (a # as) = concat (a' # as')" + using xs xs' by blast + show "concat (b # bs) = concat (b' # bs')" + using ys ys' by blast + show "a # as \ lists (- {[]})" "b # bs \ lists (- {[]})" + using ne by auto + show "strict_sorted (interact (a # as) (b # bs))" + using ss_zs \a < b\ apply (simp add: Ueq strict_sorted_append_iff) + by (metis strict_sorted_iff append.assoc append.left_neutral strict_sorted_append_iff sorted_trans) + show "length (b # bs) \ length (a # as)" "length (b' # bs') \ length (a' # as')" + using \kb \ ka\ len len' by auto + show "length (a # as) \ Suc (length (b # bs))" + using \ka \ Suc kb\ len by linarith + then show "length (a' # as') \ Suc (length (b' # bs'))" + using len len' by fastforce + show "a' # as' \ lists (- {[]})" "b' # bs' \ lists (- {[]})" + using ne' by auto + show "strict_sorted (interact (a' # as') (b' # bs'))" + using ss_zs' \a' < b'\ apply (simp add: Ueq' strict_sorted_append_iff) + by (metis strict_sorted_iff append.assoc append.left_neutral strict_sorted_append_iff sorted_trans) + show "length (a # as) = length (a' # as')" + using len'(1) len(1) by blast + show "length (b # bs) = length (b' # bs')" + using len'(2) len(2) by blast + qed + then show ?thesis + using Ueq Ueq' c c' d d' by blast +qed + + +lemma Form_Body_imp_inter_scheme: + assumes "Form_Body ka kb xs ys zs" and "0 < kb" "kb \ ka" "ka \ Suc kb" + shows "zs = inter_scheme ((ka+kb) - Suc 0) {xs,ys}" +proof - + have "length xs < length ys" + by (meson Form_Body_length assms(1)) + have [simp]: "a + a = b + b \ a=b" "a + a - Suc 0 = b + b - Suc 0 \ a=b" for a b::nat + by auto + show ?thesis + proof (cases "ka = kb") + case True + show ?thesis + unfolding inter_scheme_def + apply (rule some_equality [symmetric]) + using assms True mult_2 not_gr0 one_is_add apply fastforce + using assms \length xs < length ys\ + apply (auto simp: True mult_2 Set.doubleton_eq_iff Form_Body_unique dest: Form_Body_length) + by presburger + next + case False + then have eq: "ka = Suc kb" + using assms by linarith + show ?thesis + unfolding inter_scheme_def + apply (rule some_equality [symmetric]) + using assms False mult_2 one_is_add eq apply fastforce + using assms \length xs < length ys\ + apply (auto simp: eq mult_2 Set.doubleton_eq_iff Form_Body_unique dest: Form_Body_length) + by presburger + qed +qed + + +subsection \For Lemma 3.8 AND PROBABLY 3.7\ + +definition grab :: "nat set \ nat \ nat set \ nat set" + where "grab N n \ (N \ enumerate N ` {.. {enumerate N n..})" + +lemma grab_0 [simp]: "grab N 0 = ({}, N)" + by (fastforce simp add: grab_def enumerate_0 Least_le) + +lemma less_sets_grab: + "infinite N \ less_sets (fst (grab N n)) (snd (grab N n))" + by (auto simp: grab_def less_sets_def intro: enumerate_mono less_le_trans) + +lemma finite_grab [iff]: "finite (fst (grab N n))" + by (simp add: grab_def) + +lemma card_grab [simp]: + assumes "infinite N" shows "card (fst (grab N n)) = n" +proof - + have "N \ enumerate N ` {.. N" + using grab_def range_enum by fastforce + +lemma snd_grab_subset: "snd (grab N n) \ N" + by (auto simp: grab_def) + +lemma grab_Un_eq: + assumes "infinite N" shows "fst (grab N n) \ snd (grab N n) = N" +proof + show "N \ fst (grab N n) \ snd (grab N n)" + unfolding grab_def + using assms enumerate_Ex le_less_linear strict_mono_enum strict_mono_less by fastforce +qed (simp add: grab_def) + +lemma finite_grab_iff [simp]: "finite (snd (grab N n)) \ finite N" + by (metis finite_grab grab_Un_eq infinite_Un infinite_super snd_grab_subset) + +lemma grab_eqD: + "\grab N n = (A,M); infinite N\ + \ less_sets A M \ finite A \ card A = n \ infinite M \ A \ N \ M \ N" + using card_grab grab_def less_sets_grab finite_grab_iff by auto + +lemma less_sets_fst_grab: "less_sets A N \ less_sets A (fst (grab N n))" + by (simp add: fst_grab_subset less_sets_weaken2) + +text\Possibly redundant, given @{term grab}\ +definition nxt where "nxt \ \N. \n::nat. N \ {n<..}" + +lemma infinite_nxtN: "infinite N \ infinite (nxt N n)" + by (simp add: infinite_nat_greaterThan nxt_def) + +lemma nxt_subset: "nxt N n \ N" + unfolding nxt_def by blast + +lemma nxt_subset_greaterThan: "m \ n \ nxt N n \ {m<..}" + by (auto simp: nxt_def) + +lemma nxt_subset_atLeast: "m \ n \ nxt N n \ {m..}" + by (auto simp: nxt_def) + +lemma enum_nxt_ge: "infinite N \ a \ enum (nxt N a) n" + by (simp add: atLeast_le_enum infinite_nxtN nxt_subset_atLeast) + +lemma inj_enum_nxt: "infinite N \ inj_on (enum (nxt N a)) A" + by (simp add: infinite_nxtN strict_mono_enum strict_mono_imp_inj_on) + + +subsection \Larson's Lemma 3.11\ + +text \Again from Jean A. Larson, + A short proof of a partition theorem for the ordinal $\omega^\omega$. + \emph{Annals of Mathematical Logic}, 6:129–145, 1973.\ + +lemma lemma_3_11: + assumes "l > 0" + shows "thin (inter_scheme l ` {U. Form l U})" + using form_cases [of l] +proof cases + case zero + then show ?thesis + using assms by auto +next + case (odd k) + show ?thesis + unfolding thin_def + proof clarify + fix U U' + assume ne: "inter_scheme l U \ inter_scheme l U'" and init: "initial_segment (inter_scheme l U) (inter_scheme l U')" + assume "Form l U" + then obtain xs ys where "U = {xs,ys}" + and U: "Form_Body k k xs ys (inter_scheme l U)" + using inter_scheme [OF \Form l U\ \l > 0\] + by (metis One_nat_def less_numeral_extra(3) odd odd_eq_iffs(1) odd_eq_iffs(3)) + then obtain a as b bs c d + where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)" + and len: "length (a#as) = k" "length (b#bs) = k" + and c: "c = acc_lengths 0 (a#as)" + and d: "d = acc_lengths 0 (b#bs)" + and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs" + using Form_Body.cases by metis + assume "Form l U'" + then obtain xs' ys' where "U' = {xs',ys'}" + and U': "Form_Body k k xs' ys' (inter_scheme l U')" + using inter_scheme [OF \Form l U'\ \l > 0\] + by (metis One_nat_def Suc_pred assms double_not_eq_Suc_double odd(1) odd_eq_iffs(1) odd_eq_iffs(3)) + then obtain a' as' b' bs' c' d' + where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')" + and len': "length (a'#as') = k" "length (b'#bs') = k" + and c': "c' = acc_lengths 0 (a'#as')" + and d': "d' = acc_lengths 0 (b'#bs')" + and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'" + using Form_Body.cases by metis + have [simp]: "length bs = length as" "length bs' = length as'" + using len len' by auto + have "inter_scheme l U \ []" "inter_scheme l U' \ []" + using Form_Body_nonempty U U' by auto + define u1 where "u1 \ hd (inter_scheme l U)" + have u1_eq': "u1 = hd (inter_scheme l U')" + using \inter_scheme l U \ []\ init u1_def initial_segment_ne by fastforce + have au1: "u1 = length a" + by (simp add: u1_def Ueq c acc_lengths.simps) + have au1': "u1 = length a'" + by (simp add: u1_eq' Ueq' c' acc_lengths.simps) + have len_eqk: "length c = k" "length d = k" "length c' = k" "length d' = k" + using c d len c' d' len' by auto + have take: "take (k + u1 + k) (c @ a @ d @ l) = c @ a @ d" + "take (k + u1 + k) (c' @ a' @ d' @ l) = c' @ a' @ d'" for l + by (simp_all add: len_eqk flip: au1 au1') + have leU: "k + u1 + k \ length (inter_scheme l U)" + by (simp add: len_eqk au1 Ueq) + then have "take (k + u1 + k) (inter_scheme l U) = take (k + u1 + k) (inter_scheme l U')" + using take_initial_segment init by blast + then have \
: "c @ a @ d = c' @ a' @ d'" + by (metis append.assoc Ueq Ueq' concat.simps take) + have "length (inter_scheme l U) = k + (c @ a @ d)!(k-1) + k + last d" + by (simp add: Ueq c d length_interact nth_append len_eqk flip: len) + moreover + have "length (inter_scheme l U') = k + (c' @ a' @ d')!(k-1) + k + last d'" + by (simp add: Ueq' c' d' length_interact nth_append len_eqk flip: len') + moreover have "last d = last d'" + using "\
" au1 au1' len_eqk by auto + ultimately have "length (inter_scheme l U) = length (inter_scheme l U')" + by (simp add: \
) + then show False + using init initial_segment_length_eq ne by blast + qed +next + case (even k) + show ?thesis + unfolding thin_def + proof clarify + fix U U' + assume ne: "inter_scheme l U \ inter_scheme l U'" and init: "initial_segment (inter_scheme l U) (inter_scheme l U')" + assume "Form l U" + then obtain xs ys where "U = {xs,ys}" + and U: "Form_Body (Suc k) k xs ys (inter_scheme l U)" + using inter_scheme [OF \Form l U\ \l > 0\] + by (metis One_nat_def Suc_1 Suc_mult_cancel1 even less_numeral_extra(3) odd_eq_iffs(3)) + then obtain a as b bs c d + where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)" + and len: "length (a#as) = Suc k" "length (b#bs) = k" + and c: "c = acc_lengths 0 (a#as)" + and d: "d = acc_lengths 0 (b#bs)" + and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs" + using Form_Body.cases by metis + assume "Form l U'" + then obtain xs' ys' where "U' = {xs',ys'}" + and U': "Form_Body (Suc k) k xs' ys' (inter_scheme l U')" + using inter_scheme [OF \Form l U'\ \l > 0\] + by (metis One_nat_def Suc_1 Suc_mult_cancel1 even not_gr0 odd_eq_iffs(3)) + then obtain a' as' b' bs' c' d' + where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')" + and len': "length (a'#as') = Suc k" "length (b'#bs') = k" + and c': "c' = acc_lengths 0 (a'#as')" + and d': "d' = acc_lengths 0 (b'#bs')" + and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'" + using Form_Body.cases by metis + have [simp]: "length as = Suc (length bs)" "length as' = Suc (length bs')" + using len len' by auto + have "inter_scheme l U \ []" "inter_scheme l U' \ []" + using Form_Body_nonempty U U' by auto + define u1 where "u1 \ hd (inter_scheme l U)" + have u1_eq': "u1 = hd (inter_scheme l U')" + using \inter_scheme l U \ []\ init u1_def initial_segment_ne by fastforce + have au1: "u1 = length a" + by (simp add: u1_def Ueq c acc_lengths.simps) + have au1': "u1 = length a'" + by (simp add: u1_eq' Ueq' c' acc_lengths.simps) + have len_eqk: "length c = Suc k" "length d = k" "length c' = Suc k" "length d' = k" + using c d len c' d' len' by auto + have take: "take (Suc k + u1 + k) (c @ a @ d @ l) = c @ a @ d" + "take (Suc k + u1 + k) (c' @ a' @ d' @ l) = c' @ a' @ d'" for l + by (simp_all add: len_eqk flip: au1 au1') + have leU: "Suc k + u1 + k \ length (inter_scheme l U)" + by (simp add: len_eqk au1 Ueq) + then have "take (Suc k + u1 + k) (inter_scheme l U) = take (Suc k + u1 + k) (inter_scheme l U')" + using take_initial_segment init by blast + then have \
: "c @ a @ d = c' @ a' @ d'" + by (metis append.assoc Ueq Ueq' concat.simps take) + have "length (inter_scheme l U) = Suc k + (c @ a @ d)!k + k + last d" + by (simp add: Ueq c d length_interact nth_append len_eqk flip: len) + moreover + have "length (inter_scheme l U') = Suc k + (c' @ a' @ d')!k + k + last d'" + by (simp add: Ueq' c' d' length_interact nth_append len_eqk flip: len') + moreover have "last d = last d'" + using "\
" au1 au1' len_eqk by auto + ultimately have "length (inter_scheme l U) = length (inter_scheme l U')" + by (simp add: \
) + then show False + using init initial_segment_length_eq ne by blast + qed +qed + + +subsection \Larson's Lemma 3.6\ + +proposition lemma_3_6: + fixes g + assumes g: "g \ [WW]\<^bsup>2\<^esup> \ {..k u. \k > 0; u \ [WW]\<^bsup>2\<^esup>; Form k u; [enum N k] < inter_scheme k u; List.set (inter_scheme k u) \ N\ \ g u = j k" +proof - + define \ where "\ \ \m::nat. \M. infinite M \ m < Inf M" + define \ where "\ \ \l m n::nat. \M N j. n > m \ N \ M \ n \ M \ (\U. Form l U \ U \ WW \ [n] < inter_scheme l U \ list.set (inter_scheme l U) \ N \ g U = j)" + { fix l m::nat and M :: "nat set" + assume "l > 0" "\ m M" + let ?A = "inter_scheme l ` {U \ [WW]\<^bsup>2\<^esup>. Form l U}" + define h where "h \ \zs. g (inv_into {U \ [WW]\<^bsup>2\<^esup>. Form l U} (inter_scheme l) zs)" + have "thin ?A" + using \l > 0\ lemma_3_11 by (simp add: thin_def) + moreover + have "?A \ WW" + using inter_scheme_simple \0 < l\ by blast + moreover + have "h ` {l \ ?A. List.set l \ M} \ {..<2}" + using g inv_into_into[of concl: "{U \ [WW]\<^bsup>2\<^esup>. Form l U}" "inter_scheme l"] + by (force simp: h_def Pi_iff) + ultimately + obtain j N where "j < 2" "infinite N" "N \ M" and hj: "h ` {l \ ?A. List.set l \ N} \ {j}" + using \\ m M\ unfolding \_def by (blast intro: Nash_Williams_WW [of M]) + define n where "n \ Inf N" + have "n > m" + using \\ m M\ \infinite N\ unfolding n_def \_def Inf_nat_def infinite_nat_iff_unbounded + by (metis LeastI_ex \N \ M\ le_less_trans not_less not_less_Least subsetD) + have "g U = j" if "Form l U" "U \ WW" "[n] < inter_scheme l U" "list.set (inter_scheme l U) \ N - {n}" for U + proof - + obtain xs ys where xys: "xs \ ys" "U = {xs,ys}" + using Form_elim_upair \Form l U\ by blast + moreover have "inj_on (inter_scheme l) {U \ [WW]\<^bsup>2\<^esup>. Form l U}" + by (metis (mono_tags, lifting) inter_scheme_injective \0 < l\ inj_onI mem_Collect_eq) + moreover have "g (inv_into {U \ [WW]\<^bsup>2\<^esup>. Form l U} (inter_scheme l) (inter_scheme l U)) = j" + using hj that xys + apply (simp add: h_def image_subset_iff image_iff) + by (metis (no_types, lifting) Diff_subset doubleton_in_nsets_2 dual_order.trans) + ultimately show ?thesis + using that by auto + qed + moreover have "n < Inf (N - {n})" + unfolding n_def + by (metis Diff_iff Inf_nat_def Inf_nat_def1 \infinite N\ finite.emptyI infinite_remove linorder_neqE_nat not_less_Least singletonI) + moreover have "n \ M" + by (metis Inf_nat_def1 \N \ M\ \infinite N\ finite.emptyI n_def subsetD) + ultimately have "\ n (N - {n}) \ \ l m n M (N - {n}) j" + using \\ m M\ \infinite N\ \N \ M\ \n > m\ by (auto simp: \_def \_def) + then have "\n N j. \ n N \ \ l m n M N j" + by blast + } note * = this + have base: "\ 0 {0<..}" + unfolding \_def by (metis infinite_Ioi Inf_nat_def1 greaterThan_iff greaterThan_non_empty) + have step: "Ex (\(n,N,j). \ n N \ \ l m n M N j)" if "\ m M" "l > 0" for m M l + using * [of l m M] that by (auto simp: \_def) + define G where "G \ \l m M. @(n,N,j). \ n N \ \ (Suc l) m n M N j" + have G\: "(\(n,N,j). \ n N) (G l m M)" and G\: "(\(n,N,j). \ (Suc l) m n M N j) (G l m M)" + if "\ m M" for l m M + using step [OF that, of "Suc l"] by (force simp: G_def dest: some_eq_imp)+ + have G_increasing: "(\(n,N,j). n > m \ N \ M \ n \ M) (G l m M)" if "\ m M" for l m M + using G\ [OF that, of l] that by (simp add: \_def split: prod.split_asm) + define H where "H \ rec_nat (0,{0<..},0) (\l (m,M,j). G l m M)" + have H_simps: "H 0 = (0,{0<..},0)" "\l. H (Suc l) = (case H l of (m,M,j) \ G l m M)" + by (simp_all add: H_def) + have H\: "(\(n,N,j). \ n N) (H l)" for l + proof (induction l) + case 0 + with base show ?case + by (auto simp: H_simps) + next + case (Suc l) + with G\ show ?case + by (force simp: H_simps split: prod.split prod.split_asm) + qed + define \ where "\ \ (\l. case H l of (n,M,j) \ n)" + have H_inc: "\ l \ l" for l + proof (induction l) + case 0 + then show ?case + by auto + next + case (Suc l) + then show ?case + using H\ G_increasing [of "\ l"] + apply (auto simp: H_simps \_def split: prod.split prod.split_asm) + by (metis (mono_tags, lifting) Suc_leI Suc_le_mono case_prod_conv dual_order.trans) + qed + let ?N = "range \" + define j where "j \ \l. case H l of (n,M,j) \ j" + have H_increasing_Suc: "(case H k of (n, N, j') \ N) \ (case H (Suc k) of (n, N, j') \ insert n N)" for k + using H\ [of k] + by (force simp: H_simps split: prod.split dest: G_increasing [where l=k]) + have H_increasing_superset: "(case H k of (n, N, j') \ N) \ (case H (n+k) of (n, N, j') \ N)" for k n + proof (induction n arbitrary:) + case (Suc n) + then show ?case + using H_increasing_Suc [of "n+k"] by (auto split: prod.split_asm) + qed auto + then have H_increasing_less: "(case H k of (n, N, j') \ N) \ (case H l of (n, N, j') \ insert n N)" + if "k k < \ (Suc k)" for k + using H\ [of k] unfolding \_def + by (auto simp: H_simps split: prod.split dest: G_increasing [where l=k]) + then have strict_mono_\: "strict_mono \" + by (simp add: strict_mono_Suc_iff) + then have enum_N: "enum ?N = \" + by (metis enum_works nat_infinite_iff range_strict_mono_ext) + have **: "?N \ {n<..} \ N'" if H: "H k = (n, N', j)" for n N' k j + proof clarify + fix l + assume "n < \ l" + then have False if "l \ k" + using that strict_monoD [OF strict_mono_\, of l k ] H by (force simp: \_def) + then have "k < l" + using not_less by blast + then obtain M j where Mj: "H l = (\ l,M,j)" + unfolding \_def + by (metis (mono_tags, lifting) case_prod_conv old.prod.exhaust) + then show "\ l \ N'" + using that H_increasing_less [OF \k] Mj by auto + qed + show thesis + proof + show "infinite (?N::nat set)" + using H_inc infinite_nat_iff_unbounded_le by auto + next + fix l U + assume "0 < l" and U: "U \ [WW]\<^bsup>2\<^esup>" + and interU: "[enum ?N l] < inter_scheme l U" "Form l U" + and sub: "list.set (inter_scheme l U) \ ?N" + obtain k where k: "l = Suc k" + using \0 < l\ gr0_conv_Suc by blast + have "U \ WW" + using U by (auto simp: nsets_def) + moreover + have "g U = v" if "H k = (m, M, j0)" and "G k m M = (n, N', v)" + for m M j0 n N' v + proof - + have n: "\ (Suc k) = n" + using that by (simp add: \_def H_simps) + have "{..enum (range \) l} \ list.set (inter_scheme l U) = {}" + using inter_scheme_strict_sorted \0 < l\ interU singleton_less_list_iff strict_sorted_iff by blast + then have "list.set (inter_scheme (Suc k) U) \ N'" + using that sub ** [of "Suc k" n N' v] Suc_le_eq not_less_eq_eq + by (fastforce simp add: k n enum_N H_simps) + then show ?thesis + using that interU \U \ WW\ G\ [of m M k] H\ [of k] + by (auto simp: \_def k enum_N H_simps n) + qed + ultimately show "g U = j l" + by (auto simp: k j_def H_simps split: prod.split) + qed +qed + + +subsection \Larson's Lemma 3.7\ + +subsubsection \Preliminaries\ + +text \Analogous to @{thm [source] ordered_nsets_2_eq}, but without type classes\ +lemma total_order_nsets_2_eq: + assumes tot: "total_on A r" and irr: "irrefl r" + shows "nsets A 2 = {{x,y} | x y. x \ A \ y \ A \ (x,y) \ r}" + (is "_ = ?rhs") +proof + show "nsets A 2 \ ?rhs" + unfolding numeral_nat + apply (clarsimp simp add: nsets_def card_Suc_eq Set.doubleton_eq_iff not_less) + by (metis tot total_on_def) + show "?rhs \ nsets A 2" + using irr unfolding numeral_nat by (force simp: nsets_def card_Suc_eq irrefl_def) +qed + +lemma lenlex_nsets_2_eq: "nsets A 2 = {{x,y} | x y. x \ A \ y \ A \ (x,y) \ lenlex less_than}" + using total_order_nsets_2_eq by (simp add: total_order_nsets_2_eq irrefl_def) + +lemma sum_sorted_list_of_set_map: "finite I \ sum_list (map f (list_of I)) = sum f I" +proof (induction "card I" arbitrary: I) + case 0 + then show ?case + by auto +next + case (Suc n I) + then have [simp]: "I \ {}" + by auto + moreover have "sum_list (map f (list_of (I - {Min I}))) = sum f (I - {Min I})" + using Suc by auto + ultimately show ?case + using Suc.prems sum.remove [of I "Min I" f] + by (simp add: sorted_list_of_set_nonempty Suc) +qed + + +lemma sorted_list_of_set_UN_eq_concat: + assumes I: "strict_mono_sets I f" "finite I" and fin: "\i. finite (f i)" + shows "list_of (\i \ I. f i) = concat (map (list_of \ f) (list_of I))" + using I +proof (induction "card I" arbitrary: I) + case 0 + then have "I={}" by auto + then show ?case by auto +next + case (Suc n I) + then have "I \ {}" and Iexp: "I = insert (Min I) (I - {Min I})" + using Min_in Suc.hyps(2) Suc.prems(2) by fastforce+ + have IH: "list_of (\ (f ` (I - {Min I}))) = concat (map (list_of \ f) (list_of (I - {Min I})))" + using Suc + by (metis DiffE Min_in \I \ {}\ card_Diff_singleton diff_Suc_1 finite_Diff strict_mono_sets_def) + have "list_of (\ (f ` I)) = list_of (\ (f ` (insert (Min I) (I - {Min I}))))" + using Iexp by auto + also have "\ = list_of (f (Min I) \ \ (f ` (I - {Min I})))" + by (metis Union_image_insert) + also have "\ = list_of (f (Min I)) @ list_of (\ (f ` (I - {Min I})))" + proof (rule sorted_list_of_set_Un) + show "less_sets (f (Min I)) (\ (f ` (I - {Min I})))" + using Suc.prems \I \ {}\ strict_mono_less_sets_Min by blast + show "finite (\ (f ` (I - {Min I})))" + by (simp add: \finite I\ fin) + qed (use fin in auto) + also have "\ = list_of (f (Min I)) @ concat (map (list_of \ f) (list_of (I - {Min I})))" + using IH by metis + also have "\ = concat (map (list_of \ f) (list_of I))" + by (simp add: Suc.prems(2) \I \ {}\ sorted_list_of_set_nonempty) + finally show ?case . +qed + +subsubsection \Lemma 3.7 of Jean A. Larson, ibid.\ + +text \Possibly should be redone using grab\ +proposition lemma_3_7: + assumes "infinite N" "l > 0" + obtains M where "M \ [WW]\<^bsup>m\<^esup>" + "\U. U \ [M]\<^bsup>2\<^esup> \ Form l U \ List.set (inter_scheme l U) \ N" +proof (cases "m < 2") + case True + obtain w where w: "w \ WW" + using WW_def strict_sorted_into_WW by auto + define M where "M \ if m=0 then {} else {w}" + have M: "M \ [WW]\<^bsup>m\<^esup>" + using True by (auto simp: M_def nsets_def w) + have [simp]: "[M]\<^bsup>2\<^esup> = {}" + using True by (auto simp: M_def nsets_def w dest: subset_singletonD) + show ?thesis + using M that by fastforce +next + case False + then have "m \ 2" + by auto + have nonz: "(enum N \ Suc) i > 0" for i + using assms(1) le_enumerate less_le_trans by fastforce + note infinite_nxtN [OF \infinite N\, iff] + + have [simp]: "{n<.. \k. rec_nat ((enum N \ Suc) ` {..r D. enum (nxt N (enum (nxt N (Max D)) (Inf D - Suc 0))) ` {.. Suc) ` {.. Suc) {..infinite N\ DF_simps card_image infinite_nxtN strict_mono_enum strict_mono_imp_inj_on) + qed + have DF_ne: "DF k i \ {}" for i k + by (metis card_DF card_lessThan lessThan_empty_iff nat.simps(3)) + have DF_N: "DF k i \ N \ {0<..}" for i k + proof (induction i) + case 0 + then show ?case + using \infinite N\ range_enum nonz by (auto simp: DF_simps) + next + case (Suc i) + then show ?case + unfolding DF_simps image_subset_iff + using infinite_nxtN [OF \infinite N\] + by (metis Int_iff enumerate_in_set greaterThan_iff not_gr0 not_less0 nxt_def) + qed + then have DF_gt0: "0 < Inf (DF k i)" for i k + using DF_ne Inf_nat_def1 by blast + have finite_DF: "finite (DF k i)" for i k + by (induction i) (auto simp: DF_simps) + + have sm_enum_DF: "strict_mono_on (enum (DF k i)) {..k}" for k i + by (metis card_DF enum_works_finite finite_DF lessThan_Suc_atMost) + + have DF_Suc: "less_sets (DF k i) (DF k (Suc i))" for i k + unfolding less_sets_def + by (force simp: finite_DF DF_simps + intro!: greaterThan_less_enum nxt_subset_greaterThan atLeast_le_enum nxt_subset_atLeast infinite_nxtN [OF \infinite N\]) + have DF_DF: "less_sets (DF k i) (DF k j)" if "i \k i. enum (nxt N (Max (DF k i))) ` {.. {}" for i k + by (auto simp: AF_def lessThan_empty_iff DF_gt0) + have finite_AF [simp]: "finite (AF k i)" for i k + by (simp add: AF_def) + have card_AF: "card (AF k i) = \ (DF k i)" for k i + by (simp add: AF_def \infinite N\ card_image inj_enum_nxt) + + have DF_AF: "less_sets (DF k i) (AF k i)" for i k + unfolding less_sets_def AF_def + by (simp add: finite_DF \infinite N\ greaterThan_less_enum nxt_subset_greaterThan) + + have AF_DF_Suc: "less_sets (AF k i) (DF k (Suc i))" for i k + apply (clarsimp simp: DF_simps less_sets_def AF_def) + using strict_monoD [OF strict_mono_enum] + by (metis DF_gt0 Suc_pred assms(1) dual_order.order_iff_strict greaterThan_less_enum + infinite_nxtN linorder_neqE_nat not_less_eq nxt_subset_greaterThan) + + have AF_DF: "less_sets (AF k p) (DF k q)" if "p \k i j. enum (DF k i) j - enum (DF k i) (j - Suc 0)" + + define QF where "QF k \ wfrec pair_less (\f (j,i). + if j=0 then AF k i + else let r = (if i=0 then f (j-1,m-1) else f (j,i-1)) in + enum (nxt N (Suc (Max r))) ` {..< del k (if j=k then m - Suc i else i) j})" + for k + note cut_apply [simp] + + have finite_QF [simp]: "finite (QF k p)" for p k + using wf_pair_less + proof (induction p rule: wf_induct_rule) + case (less p) + then show ?case + by (simp add: def_wfrec [OF QF_def, of k p] split: prod.split) + qed + + have del_gt_0: "\j < Suc k; 0 < j\ \ 0 < del k i j" for i j k + by (simp add: card_DF del_def finite_DF) + + have QF_ne [simp]: "QF k (j,i) \ {}" if j: "j < Suc k" for j i k + using wf_pair_less j + proof (induction "(j,i)" rule: wf_induct_rule) + case less + then show ?case + by (auto simp: def_wfrec [OF QF_def, of k "(j,i)"] AF_ne lessThan_empty_iff del_gt_0) + qed + + have QF_0 [simp]: "QF k (0,i) = AF k i" for i k + by (simp add: def_wfrec [OF QF_def]) + + have QF_Suc: "QF k (Suc j,0) = enum (nxt N (Suc (Max (QF k (j, m - Suc 0))))) ` + {..< del k (if Suc j = k then m - 1 else 0) (Suc j)}" for j k + apply (simp add: def_wfrec [OF QF_def, of k "(Suc j,0)"]) + apply (simp add: pair_less_def cut_def) + done + + have QF_Suc_Suc: "QF k (Suc j, Suc i) + = enum (nxt N (Suc (Max (QF k (Suc j, i))))) ` {..< del k (if Suc j = k then m - Suc(Suc i) else Suc i) (Suc j)}" + for i j k + by (simp add: def_wfrec [OF QF_def, of k "(Suc j,Suc i)"]) + + have less_QF1: "less_sets (QF k (j, m - Suc 0)) (QF k (Suc j,0))" for j k + by (auto simp: def_wfrec [OF QF_def, of k "(Suc j,0)"] pair_lessI1 \infinite N\ enum_nxt_ge + intro!: less_sets_weaken2 [OF less_sets_Suc_Max]) + + have less_QF2: "less_sets (QF k (j,i)) (QF k (j, Suc i))" for j i k + by (auto simp: def_wfrec [OF QF_def, of k "(j, Suc i)"] pair_lessI2 \infinite N\ enum_nxt_ge + intro: less_sets_weaken2 [OF less_sets_Suc_Max] strict_mono_setsD [OF sm_AF]) + + have less_QF_same: "less_sets (QF k (j,i')) (QF k (j,i))" + if "i' < i" "j \ k" for i' i j k + proof (rule strict_mono_setsD [OF less_sets_imp_strict_mono_sets [of "\i. QF k (j,i)"]]) + show "less_sets (QF k (j, i)) (QF k (j, Suc i))" for i + by (simp add: less_QF2) + show "QF k (j, i) \ {}" if "0 < i" for i + using that by (simp add: \j \ k\ le_imp_less_Suc) + qed (use that in auto) + + have less_QF_step: "less_sets (QF k (j - Suc 0, i')) (QF k (j,i))" + if "0 < j" "j \ k" "i' < m" for j i' i k + proof - + have less_QF1': "less_sets (QF k (j - Suc 0, m - Suc 0)) (QF k (j,0))" if "j > 0" for j + by (metis less_QF1 that Suc_pred) + have \
: "less_sets (QF k (j - Suc 0, i')) (QF k (j,0))" + proof (cases "i' = m - Suc 0") + case True + then show ?thesis + using less_QF1' \0 < j\ by blast + next + case False + show ?thesis + using False that less_sets_trans [OF less_QF_same less_QF1' QF_ne] by auto + qed + then show ?thesis + by (metis QF_ne less_QF_same less_Suc_eq_le less_sets_trans \j \ k\ zero_less_iff_neq_zero) + qed + + have less_QF: "less_sets (QF k (j',i')) (QF k (j,i))" + if j: "j' < j" "j \ k" and i: "i' < m" "i < m" for j' j i' i k + using j + proof (induction "j-j'" arbitrary: j) + case 0 + then show ?case + by auto + next + case (Suc d) + then have eq: "d = (j - Suc 0) - j'" + by linarith + show ?case + proof (cases "j' < j - Suc 0") + case True + then have "less_sets (QF k (j', i')) (QF k (j - Suc 0, i))" + using Suc eq by auto + then show ?thesis + by (rule less_sets_trans [OF _ less_QF_step QF_ne]) (use Suc i in auto) + next + case False + then have "j' = j - Suc 0" + using \j' < j\ by linarith + then show ?thesis + using Suc.hyps \j \ k\ less_QF_step i by auto + qed + qed + + have sm_QF: "strict_mono_sets ({..k} \ {.. {..k} \ {.. {..k} \ {..: "p = (j',i')" "q = (j,i)" "i' < m" "i < m" "j' \ k" "j \ k" + using surj_pair [of p] surj_pair [of q] by blast + with \p < q\ have "j' < j \ j' = j \ i' < i" + by auto + then show "less_sets (QF k p) (QF k q)" + proof (elim conjE disjE) + assume "j' < j" + show "less_sets (QF k p) (QF k q)" + by (simp add: \
\j' < j\ less_QF that) + qed (use \
in \simp add: that less_QF_same\) + qed + then have sm_QF1: "strict_mono_sets {..j. QF k (j,i))" + if "i ka" "ka \ k" for ka k i + proof - + have "{.. {..k}" + by (metis lessThan_Suc_atMost lessThan_subset_iff \Suc k \ ka\) + then show ?thesis + by (simp add: less_QF strict_mono_sets_def subset_iff that) + qed + + have disjoint_QF: "i'=i \ j'=j" if "\ disjnt (QF k (j', i')) (QF k (j,i))" "j' \ k" "j \ k" "i' < m" "i < m" for i' i j' j k + using that strict_mono_sets_imp_disjoint [OF sm_QF] + by (force simp: pairwise_def) + + have card_QF: "card (QF k (j,i)) = (if j=0 then \ (DF k i) else del k (if j = k then m - Suc i else i) j)" + for i k j + proof (cases j) + case 0 + then show ?thesis + by (simp add: AF_def card_image \infinite N\ inj_enum_nxt) + next + case (Suc j') + show ?thesis + by (cases i; simp add: Suc QF_Suc QF_Suc_Suc card_image \infinite N\ inj_enum_nxt) + qed + have AF_non_Nil: "list_of (AF k i) \ []" for k i + by (simp add: AF_ne) + have QF_non_Nil: "list_of (QF k (j,i)) \ []" if "j < Suc k" for i j k + by (simp add: that) + + have AF_subset_N: "AF k i \ N" for i k + unfolding AF_def image_subset_iff + using nxt_subset enumerate_in_set infinite_nxtN \infinite N\ by blast + + have QF_subset_N: "QF k (j,i) \ N" for i j k + proof (induction j) + case 0 + with AF_subset_N show ?case + by auto + next + case (Suc j) + show ?case + by (cases i) (use nxt_subset enumerate_in_set in \(force simp: QF_Suc QF_Suc_Suc)+\) + qed + + obtain ka k where "k>0" and kka: "k \ ka" "ka \ Suc k" "l = ((ka+k) - Suc 0)" + proof - + consider (odd) k where "l = 2*k - Suc 0" "k > 0" | (even) k where "l = 2*k" "k > 0" + by (metis One_nat_def \l > 0\ form_cases not_gr0) + then show thesis + proof cases + case odd + then show ?thesis + by (metis lessI less_or_eq_imp_le mult_2 that) + next + case even + then show ?thesis + by (metis add_Suc diff_Suc_Suc lessI less_or_eq_imp_le minus_nat.diff_0 mult_2 that) + qed + qed + then have "ka > 0" + using dual_order.strict_trans1 by blast + have ka_k_or_Suc: "ka = k \ ka = Suc k" + using kka by linarith + have lessThan_k: "{..0" for k::nat + using that by auto + then have sorted_list_of_set_k: "list_of {..0" for k::nat + using sorted_list_of_set_insert [of concl: 0 "{0<.. \j i. if j = k then QF k (j, m - Suc i) else QF k (j,i)" + have RF_subset_N: "RF j i \ N" if "i0 < k\ by auto + have disjoint_RF: "i'=i \ j'=j" if "\ disjnt (RF j' i') (RF j i)" "j' \ k" "j \ k" "i' < m" "i < m" for i' i j' j + using disjoint_QF that + by (auto simp: RF_def split: if_split_asm dest: disjoint_QF) + + have sum_card_RF [simp]: "(\j\n. card (RF j i)) = enum (DF k i) n" if "n \ k" "i < m" for i n + using that + proof (induction n) + case 0 + then show ?case + using DF_ne [of k i] finite_DF [of k i] \k>0\ + by (simp add: RF_def AF_def card_image \infinite N\ inj_enum_nxt enum_0_eq_Inf_finite) + next + case (Suc n) + then have "enum (DF k i) 0 \ enum (DF k i) n \ enum (DF k i) n \ enum (DF k i) (Suc n)" + using sm_enum_DF [of k i] + apply (simp add: strict_mono_on_def) + by (metis Suc_leD dual_order.order_iff_strict le0) + with Suc show ?case + by (auto simp: RF_def card_QF del_def) + qed + have DF_in_N: "enum (DF k i) j \ N" if "j \ k" for i j + using DF_N [of k i] card_DF finite_enumerate_in_set finite_DF that + by (metis inf.boundedE le_imp_less_Suc subsetD) + have Inf_DF_N: "\(DF k p) \ N" for k p + using DF_N DF_ne Inf_nat_def1 by blast + have RF_in_N: "(\j\n. card (RF j i)) \ N" if "n \ k" "i < m" for i n + by (auto simp: DF_in_N that) + + have "ka - Suc 0 \ k" + using kka(2) by linarith + then have sum_card_RF' [simp]: + "(\j0 < ka\ lessThan_Suc_atMost that) + + have enum_DF_le_iff [simp]: + "enum (DF k i) j \ enum (DF k i') j \ i \ i'" (is "?lhs = _") + if "j \ k" for i' i j k + proof + show "i \ i'" if ?lhs + proof - + have "enum (DF k i) j \ DF k i" + by (simp add: card_DF finite_enumerate_in_set finite_DF le_imp_less_Suc \j \ k\) + moreover have "enum (DF k i') j \ DF k i'" + by (simp add: \j \ k\ card_DF finite_enumerate_in_set finite_DF le_imp_less_Suc that) + ultimately have "enum (DF k i') j < enum (DF k i) j" if "i' < i" + using sm_DF [of k] by (meson UNIV_I less_sets_def strict_mono_setsD that) + then show ?thesis + using not_less that by blast + qed + show ?lhs if "i \ i'" + using sm_DF [of k] that \j \ k\ card_DF finite_enumerate_in_set finite_DF le_eq_less_or_eq + by (force simp: strict_mono_sets_def less_sets_def finite_enumerate_in_set) + qed + then have enum_DF_eq_iff[simp]: + "enum (DF k i) j = enum (DF k i') j \ i = i'" if "j \ k" for i' i j k + by (metis le_antisym order_refl that) + have enum_DF_less_iff [simp]: + "enum (DF k i) j < enum (DF k i') j \ i < i'" if "j \ k" for i' i j k + by (meson enum_DF_le_iff not_less that) + + have card_AF_sum: "card (AF k i) + (\j\{0<..k > 0\ \k \ ka\ \ka \ Suc k\ + by (simp add: lessThan_k RF_0 flip: sum_card_RF') + + have sorted_list_of_set_iff [simp]: "list_of {0<.. k = Suc 0" if "k>0" for k::nat + proof - + have "list_of {0<.. {0<.. \ k = Suc 0" + using \k > 0\ atLeastSucLessThan_greaterThanLessThan by fastforce + finally show ?thesis . + qed + show thesis \\proof of main result\ + proof + have inj: "inj_on (\i. list_of (\jjjjj RF 0 x" + using AF_ne QF_0 \0 < k\ Inf_nat_def1 \k \ ka\ by (force simp: RF_def) + with eq \ka > 0\ obtain j' where "j' < ka" "n \ RF j' y" + by blast + then show ?thesis + using disjoint_QF [of k 0 x j'] n \x < m\ \y < m\ \ka \ Suc k\ \0 < k\ + by (force simp: RF_def disjnt_iff simp del: QF_0 split: if_split_asm) + qed + qed + + define M where "M \ (\i. list_of (\jk \ ka\ card_image inj) + moreover have "M \ WW" + by (force simp: M_def WW_def) + ultimately show "M \ [WW]\<^bsup>m\<^esup>" + by (simp add: nsets_def) + + have sm_RF: "strict_mono_sets {..j. RF j i)" if "i []" if "j < Suc k" for i j + using that by (simp add: RF_def) + + have less_RF_same: "less_sets (RF j i') (RF j i)" + if "i' < i" "j < k" for i' i j + using that by (simp add: less_QF_same RF_def) + + have less_RF_same_k: "less_sets (RF k i') (RF k i)" \\reversed version for @{term k}\ + if "i < i'" "i' < m" for i' i + using that by (simp add: less_QF_same RF_def) + + show "Form l U \ list.set (inter_scheme l U) \ N" if "U \ [M]\<^bsup>2\<^esup>" for U + proof - + from that obtain x y where "U = {x,y}" "x \ M" "y \ M" and xy: "(x,y) \ lenlex less_than" + by (auto simp: lenlex_nsets_2_eq) + let ?R = "\p. list_of \ (\j. RF j p)" + obtain p q where x: "x = list_of (\jjx \ M\ \y \ M\ by (auto simp: M_def) + then have pq: "pk \ ka\ \ka \ Suc k\ lexl_not_refl [OF irrefl_less_than] + by (auto simp: lenlex_def sm_RF sorted_list_of_set_UN_lessThan length_concat sum_sorted_list_of_set_map) + moreover + have xc: "x = concat (map (?R p) (list_of {..k \ ka\ \ka \ Suc k\ \p < m\ sm_RF) + have yc: "y = concat (map (?R q) (list_of {..k \ ka\ \ka \ Suc k\ \q < m\ sm_RF) + have enum_DF_AF: "enum (DF k p) (ka - Suc 0) < hd (list_of (AF k p))" for p + proof (rule less_setsD [OF DF_AF]) + show "enum (DF k p) (ka - Suc 0) \ DF k p" + using \ka \ Suc k\ card_DF finite_DF by (auto simp: finite_enumerate_in_set) + show "hd (list_of (AF k p)) \ AF k p" + using AF_non_Nil finite_AF hd_in_set set_sorted_list_of_set by blast + qed + + have less_RF_RF: "less_sets (RF n p) (RF n q)" if "n < k" for n + using that \p by (simp add: less_RF_same) + have less_RF_Suc: "less_sets (RF n q) (RF (Suc n) q)" if "n < k" for n + using \q < m\ that by (auto simp: RF_def less_QF) + have less_RF_k: "less_sets (RF k q) (RF k p)" + using \q < m\ less_RF_same_k \p by blast + have less_RF_k_ka: "less_sets (RF (k - Suc 0) p) (RF (ka - Suc 0) q)" + using ka_k_or_Suc less_RF_RF + by (metis One_nat_def RF_def \0 < k\ \ka - Suc 0 \ k\ \p < m\ diff_Suc_1 diff_Suc_less less_QF_step) + have Inf_DF_eq_enum: "\ (DF k i) = enum (DF k i) 0" for k i + by (simp add: Inf_nat_def enumerate_0) + + have Inf_DF_less: "\ (DF k i') < \ (DF k i)" if "i'x. x \ AF k i \ \ (DF k i') < x" if "i'\i" for i' i + using less_setsD [OF DF_AF] DF_ne that + by (metis Inf_DF_less Inf_nat_def1 dual_order.order_iff_strict dual_order.strict_trans) + + show ?thesis + proof (cases "k=1") + case True + with kka consider "ka=1" | "ka=2" by linarith + then show ?thesis + proof cases + case 1 + define zs where "zs = card (AF 1 p) # list_of (AF 1 p) + @ card (AF 1 q) # list_of (AF 1 q)" + have zs: "Form_Body ka k x y zs" + proof (intro that exI conjI Form_Body.intros [OF \length x < length y\]) + show "x = concat ([list_of (AF k p)])" "y = concat ([list_of (AF k q)])" + by (simp_all add: x y 1 lessThan_Suc RF_0) + have "less_sets (AF k p) (insert (\ (DF k q)) (AF k q))" + by (metis AF_DF DF_ne Inf_nat_def1 RF_0 \0 < k\ insert_iff less_RF_RF less_sets_def pq(1)) + then have "strict_sorted (list_of (AF k p) @ \ (DF k q) # list_of (AF k q))" + by (auto simp: strict_sorted_append_iff intro: less_sets_imp_list_less AF_Inf_DF_less) + moreover have "\x. x \ AF k q \ \ (DF k p) < x" + by (meson AF_Inf_DF_less less_imp_le_nat \p < q\) + ultimately show "strict_sorted zs" + using \p < q\ True Inf_DF_less DF_AF DF_ne + apply (auto simp: zs_def less_sets_def card_AF AF_Inf_DF_less) + by (meson Inf_nat_def1) + qed (auto simp: \k=1\ \ka=1\ acc_lengths.simps zs_def AF_ne) + have zs_N: "list.set zs \ N" + using AF_subset_N by (auto simp: zs_def card_AF Inf_DF_N \k=1\) + show ?thesis + proof + have "l = 1" + using kka \k=1\ \ka=1\ by auto + have "Form (2*1-1) {x,y}" + using "1" Form.intros(2) True zs by fastforce + then show "Form l U" + by (simp add: \U = {x,y}\ \l = 1\) + show "list.set (inter_scheme l U) \ N" + using kka zs zs_N \k=1\ Form_Body_imp_inter_scheme by (fastforce simp add: \U = {x,y}\) + qed + next + case 2 + note True [simp] note 2 [simp] + have [simp]: "{0<..<2} = {Suc 0}" + by auto + have enum_DF1_eq: "enum (DF (Suc 0) i) (Suc 0) = card (AF (Suc 0) i) + card (RF (Suc 0) i)" + if "i < m" for i + using card_AF_sum that by simp + have card_RF: "card (RF (Suc 0) i) = enum (DF (Suc 0) i) (Suc 0) - enum (DF (Suc 0) i) 0" if "i < m" for i + using that by (auto simp: RF_def card_QF del_def) + have list_of_AF_RF: "list_of (AF (Suc 0) q \ RF (Suc 0) q) = list_of (AF (Suc 0) q) @ list_of (RF (Suc 0) q)" + using RF_def \q < m\ less_QF_step by (fastforce intro!: sorted_list_of_set_Un) + + define zs where "zs = card (AF 1 p) # (card (AF 1 p) + card (RF 1 p)) + # list_of (AF 1 p) + @ (card (AF 1 q) + card (RF 1 q)) # list_of (AF 1 q) @ list_of (RF 1 q) @ list_of (RF 1 p)" + have zs: "Form_Body ka k x y zs" + proof (intro that exI conjI Form_Body.intros [OF \length x < length y\]) + have "x = list_of (RF 0 p \ RF (Suc 0) p)" + by (simp add: x eval_nat_numeral lessThan_Suc RF_0 Un_commute) + also have "\ = list_of (RF 0 p) @ list_of (RF (Suc 0) p)" + using RF_def True \p < m\ less_QF_step + by (subst sorted_list_of_set_Un) (fastforce+) + finally show "x = concat ([list_of (AF 1 p),list_of (RF 1 p)])" + by (simp add: RF_0) + show "y = concat [list_of (RF 1 q \ AF 1 q)]" + by (simp add: y eval_nat_numeral lessThan_Suc RF_0) + show "zs = concat [[card (AF 1 p), card (AF 1 p) + card (RF 1 p)], list_of (AF 1 p), + [card (AF 1 q) + card (RF 1 q)], list_of (RF 1 q \ AF 1 q)] @ interact [list_of (RF 1 p)] []" + using list_of_AF_RF by (simp add: zs_def Un_commute) + show "strict_sorted zs" + proof (simp add: \p \q \p zs_def strict_sorted_append_iff, intro conjI strip) + show "0 < card (RF (Suc 0) p)" + using \p by (simp add: card_RF card_DF finite_DF) + show "card (AF (Suc 0) p) < card (AF (Suc 0) q) + card (RF (Suc 0) q)" + using \p \q by (simp add: Inf_DF_less card_AF trans_less_add1) + show "card (AF (Suc 0) p) < x" + if "x \ AF (Suc 0) p \ (AF (Suc 0) q \ (RF (Suc 0) q \ RF (Suc 0) p))" for x + using that + apply (simp add: card_AF) + by (metis AF_ne DF_AF DF_ne less_RF_RF less_RF_Suc less_RF_k Inf_nat_def1 One_nat_def RF_0 RF_non_Nil True finite_RF lessI less_setsD less_sets_trans sorted_list_of_set_eq_Nil_iff) + show "card (AF (Suc 0) p) + card (RF (Suc 0) p) < card (AF (Suc 0) q) + card (RF (Suc 0) q)" + using \p < q\ \p < m\ \q < m\ by (metis enum_DF1_eq enum_DF_less_iff le_refl) + show "card (AF (Suc 0) p) + card (RF (Suc 0) p) < x" + if "x \ AF (Suc 0) p \ (AF (Suc 0) q \ (RF (Suc 0) q \ RF (Suc 0) p))" for x + using that \p < m\ + apply (simp add: flip: enum_DF1_eq) + by (metis AF_ne DF_AF less_RF_RF less_RF_Suc less_RF_k One_nat_def RF_0 RF_non_Nil Suc_mono True \0 < k\ card_DF finite_enumerate_in_set finite_DF less_setsD less_sets_trans sorted_list_of_set_empty) + have "list_of (AF (Suc 0) p) < list_of {enum (DF (Suc 0) q) (Suc 0)}" + proof (rule less_sets_imp_sorted_list_of_set) + show "less_sets (AF (Suc 0) p) {enum (DF (Suc 0) q) (Suc 0)}" + by (metis (no_types, lifting) AF_DF DF_ne Inf_nat_def1 \q < m\ card_AF enum_DF1_eq less_setsD less_sets_singleton2 pq(1) trans_less_add1) + qed auto + then show "list_of (AF (Suc 0) p) < (card (AF (Suc 0) q) + card (RF (Suc 0) q)) # list_of (AF (Suc 0) q) @ list_of (RF (Suc 0) q) @ list_of (RF (Suc 0) p)" + using \q < m\ by (simp add: less_list_def enum_DF1_eq) + show "card (AF (Suc 0) q) + card (RF (Suc 0) q) < x" + if "x \ AF (Suc 0) q \ (RF (Suc 0) q \ RF (Suc 0) p)" for x + using that \q < m\ + apply (simp flip: enum_DF1_eq) + by (metis AF_ne DF_AF less_RF_Suc less_RF_k One_nat_def RF_0 RF_non_Nil True card_DF finite_enumerate_in_set finite_DF finite_RF lessI less_setsD less_sets_trans sorted_list_of_set_eq_Nil_iff) + have "list_of (AF (Suc 0) q) < list_of (RF (Suc 0) q)" + proof (rule less_sets_imp_sorted_list_of_set) + show "less_sets (AF (Suc 0) q) (RF (Suc 0) q)" + by (metis less_RF_Suc One_nat_def RF_0 True \0 < k\) + qed auto + then show "list_of (AF (Suc 0) q) < list_of (RF (Suc 0) q) @ list_of (RF (Suc 0) p)" + using RF_non_Nil by (auto simp: less_list_def) + show "list_of (RF (Suc 0) q) < list_of (RF (Suc 0) p)" + proof (rule less_sets_imp_sorted_list_of_set) + show "less_sets (RF (Suc 0) q) (RF (Suc 0) p)" + by (metis less_RF_k One_nat_def True) + qed auto + qed + show "[list_of (AF 1 p), list_of (RF 1 p)] \ lists (- {[]})" + using RF_non_Nil \0 < k\ by (auto simp: acc_lengths.simps zs_def AF_ne) + show "[card (AF 1 q) + card (RF 1 q)] = acc_lengths 0 [list_of (RF 1 q \ AF 1 q)]" + using list_of_AF_RF + by (auto simp: acc_lengths.simps zs_def AF_ne sup_commute) + qed (auto simp: acc_lengths.simps zs_def AF_ne) + have zs_N: "list.set zs \ N" + using \p < m\ \q < m\ DF_in_N enum_DF1_eq [symmetric] + by (auto simp: zs_def card_AF AF_subset_N RF_subset_N Inf_DF_N) + show ?thesis + proof + have "Form (2*1) {x,y}" + by (metis "2" Form.simps Suc_1 True zero_less_one zs) + with kka show "Form l U" + by (simp add: \U = {x,y}\) + show "list.set (inter_scheme l U) \ N" + using kka zs zs_N \k=1\ Form_Body_imp_inter_scheme by (fastforce simp add: \U = {x, y}\) + qed + qed + next + case False + then have "k \ 2" "ka \ 2" + using kka \k>0\ by auto + then have k_minus_1 [simp]: "Suc (k - Suc (Suc 0)) = k - Suc 0" + by auto + + define PP where "PP \ map (?R p) (list_of {0<.. map (?R q) (list_of {0<.. RF (ka-1) q)])" + let ?INT = "interact PP QQ" + \\No separate sets A and B as in the text, but instead we treat both cases as once\ + have [simp]: "length PP = ka - 1" + by (simp add: PP_def) + have [simp]: "length QQ = k - 1" + using \k \ 2\ by (simp add: QQ_def) + + have PP_n: "PP ! n = list_of (RF (Suc n) p)" + if "n < ka-1" for n + using that kka by (auto simp: PP_def nth_sorted_list_of_set_greaterThanLessThan) + + have QQ_n: "QQ ! n = (if n < k - Suc (Suc 0) then list_of (RF (Suc n) q) + else list_of (RF (k - Suc 0) q \ RF (ka - Suc 0) q))" + if "n < k-1" for n + using that kka by (auto simp: QQ_def nth_append nth_sorted_list_of_set_greaterThanLessThan) + + have QQ_n_same: "QQ ! n = list_of (RF (Suc n) q)" + if "n < k - Suc 0" "k=ka" for n + using that kka Suc_diff_Suc + by (fastforce simp add: QQ_def nth_append nth_sorted_list_of_set_greaterThanLessThan) + + have split_nat_interval: "{0<.. 2" for n + using that by auto + have split_list_interval: "list_of{0<.. 2" for n + proof (intro sorted_list_of_set_unique [THEN iffD1] conjI) + have "list_of {0<..n \ 2\ in auto) + + have list_of_RF_Un: "list_of (RF (k - Suc 0) q \ RF k q) = list_of (RF (k - Suc 0) q) @ list_of (RF k q)" + by (metis less_RF_Suc Suc_pred \0 < k\ diff_Suc_less finite_RF sorted_list_of_set_Un) + + have card_AF_sum_QQ: "card (AF k q) + sum_list (map length QQ) = (\j RF k q = {}" + using less_RF_Suc [of "k - Suc 0"] \k > 0\ by (auto simp: less_sets_def) + then have "card (RF (k - Suc 0) q \ RF k q) = card (RF (k - Suc 0) q) + card (RF k q)" + by (simp add: card_Un_disjoint) + then show ?thesis + using \k\2\ \q < m\ + apply (simp add: QQ_def True flip: RF_0) + apply (simp add: lessThan_k split_nat_interval sum_sorted_list_of_set_map) + done + next + case False + with kka have "ka=k" by linarith + with \k\2\ show ?thesis by (simp add: QQ_def lessThan_k split_nat_interval sum_sorted_list_of_set_map flip: RF_0) + qed + + define LENS where "LENS \ \i. acc_lengths 0 (list_of (AF k i) # map (?R i) (list_of {0<.. N" if "i < m" for i + proof - + have eq: "(list_of (AF k i) # map (?R i) (list_of {0<..0 < ka\ sorted_list_of_set_k by auto + let ?f = "rec_nat [card (AF k i)] (\n r. r @ [(\j\Suc n. card (RF j i))])" + have f: "acc_lengths 0 (map (?R i) (list_of {..v})) = ?f v" for v + by (induction v) (auto simp: RF_0 acc_lengths.simps acc_lengths_append sum_sorted_list_of_set_map) + have 3: "list.set (?f v) \ N" if "v \ k" for v + using that + proof (induction v) + case 0 + have "card (AF k i) \ N" + by (metis DF_N DF_ne Inf_nat_def1 Int_subset_iff card_AF subsetD) + with 0 show ?case by simp + next + case (Suc v) + then have "enum (DF k i) (Suc v) \ N" + by (metis DF_N Int_subset_iff card_DF finite_enumerate_in_set finite_DF in_mono le_imp_less_Suc) + with Suc \i < m\ show ?case + by (simp del: sum.atMost_Suc) + qed + show ?thesis + unfolding LENS_def + by (metis "3" Suc_pred \0 < ka\ \ka - Suc 0 \ k\ eq f lessThan_Suc_atMost) + qed + define LENS_QQ where "LENS_QQ \ acc_lengths 0 (list_of (AF k q) # QQ)" + have LENS_QQ_subset: "list.set LENS_QQ \ list.set (LENS q)" + proof (cases "ka = Suc k") + case True + with \k \ 2\ show ?thesis + unfolding QQ_def LENS_QQ_def LENS_def + by (auto simp: list_of_RF_Un split_list_interval acc_lengths.simps acc_lengths_append) + next + case False + then have "ka=k" + using kka by linarith + with \k \ 2\ show ?thesis + by (simp add: QQ_def LENS_QQ_def LENS_def split_list_interval) + qed + have ss_INT: "strict_sorted ?INT" + proof (rule strict_sorted_interact_I) + fix n + assume "n < length QQ" + then have n: "n < k-1" + by simp + have "n = k - Suc (Suc 0)" if "\ n < k - Suc (Suc 0)" + using n that by linarith + with \p n show "PP ! n < QQ ! n" + using \0 < k\ \k \ ka\ \ka \ Suc k\ \p n + by (auto simp: PP_n QQ_n less_RF_same less_sets_imp_sorted_list_of_set less_sets_Un2 less_RF_RF less_RF_k_ka) + next + fix n + have V: "\Suc n < ka - Suc 0\ \ list_of (RF (Suc n) q) < list_of (RF (Suc (Suc n)) p)" for n + by (smt One_nat_def RF_def Suc_leI \ka - Suc 0 \ k\ \q < m\ diff_Suc_1 finite_RF less_QF_step less_le_trans less_sets_imp_sorted_list_of_set nat_neq_iff zero_less_Suc) + have "less_sets (RF (k - Suc 0) q) (RF k p)" + by (metis less_RF_Suc less_RF_k RF_non_Nil Suc_pred \0 < k\ finite_RF lessI less_sets_trans sorted_list_of_set_eq_Nil_iff) + with kka have "less_sets (RF (k - Suc 0) q \ RF (ka - Suc 0) q) (RF k p)" + by (metis less_RF_k One_nat_def less_sets_Un1 antisym_conv2 diff_Suc_1 le_less_Suc_eq) + then have VI: "list_of (RF (k - Suc 0) q \ RF (ka - Suc 0) q) < list_of (RF k p)" + by (rule less_sets_imp_sorted_list_of_set) auto + assume "Suc n < length PP" + with \ka \ Suc k\ VI + show "QQ ! n < PP ! Suc n" + apply (auto simp: PP_n QQ_n less_RF_same less_sets_imp_sorted_list_of_set less_sets_Un1 less_sets_Un2 less_RF_RF less_RF_k_ka V) + by (metis One_nat_def Suc_less_eq Suc_pred \0 < k\ diff_Suc_1 k_minus_1 ka_k_or_Suc less_SucE) + next + show "PP \ lists (- {[]})" + using RF_non_Nil kka + by (clarsimp simp: PP_def) (metis RF_non_Nil less_le_trans) + show "QQ \ lists (- {[]})" + using RF_non_Nil kka + by (clarsimp simp: QQ_def) (metis RF_non_Nil Suc_pred \0 < k\ less_SucI) + qed (use kka PP_def QQ_def in auto) + then have ss_QQ: "strict_sorted (concat QQ)" + using strict_sorted_interact_imp_concat by blast + + obtain zs where zs: "Form_Body ka k x y zs" and zs_N: "list.set zs \ N" + proof (intro that exI conjI Form_Body.intros [OF \length x < length y\]) + show "x = concat (list_of (AF k p) # PP)" + using \ka > 0\ by (simp add: PP_def RF_0 xc sorted_list_of_set_k) + let ?YR = "(map (list_of \ (\j. RF j q)) (list_of {0<..ka - Suc 0 \ k\ add.left_neutral finite_RF less_le_trans less_sets_imp_sorted_list_of_set nth_sorted_list_of_set_greaterThanLessThan) + next + show "?YR \ lists (- {[]})" + using RF_non_Nil \ka \ Suc k\ by (auto simp: mem_lists_non_Nil) + qed auto + show "list.set (concat ?YR) = list.set (concat QQ)" + using ka_k_or_Suc + proof + assume "ka = k" + then show "list.set (concat (map (list_of \ (\j. RF j q)) (list_of {0<..k\2\ by simp (simp add: split_nat_interval QQ_def) + next + assume "ka = Suc k" + then show "list.set (concat (map (list_of \ (\j. RF j q)) (list_of {0<..k\2\ by simp (auto simp: QQ_def split_nat_interval) + qed + qed + then show "y = concat (list_of (AF k q) # QQ)" + using \ka > 0\ by (simp add: RF_0 yc sorted_list_of_set_k) + show "list_of (AF k p) # PP \ lists (- {[]})" "list_of (AF k q) # QQ \ lists (- {[]})" + using RF_non_Nil kka by (auto simp: AF_ne PP_def QQ_def eq_commute [of "[]"]) + show "list.set ((LENS p @ list_of (AF k p) @ LENS_QQ @ list_of (AF k q) @ ?INT)) \ N" + using AF_subset_N RF_subset_N LENS_subset_N \p < m\ \q < m\ LENS_QQ_subset + by (auto simp: subset_iff PP_def QQ_def) + show "length (list_of (AF k p) # PP) = ka" "length (list_of (AF k q) # QQ) = k" + using \0 < ka\ \0 < k\ by auto + show "LENS p = acc_lengths 0 (list_of (AF k p) # PP)" + by (auto simp: LENS_def PP_def) + show "strict_sorted (LENS p @ list_of (AF k p) @ LENS_QQ @ list_of (AF k q) @ ?INT)" + unfolding strict_sorted_append_iff + proof (intro conjI ss_INT) + show "LENS p < list_of (AF k p) @ LENS_QQ @ list_of (AF k q) @ ?INT" + using AF_non_Nil [of k p] \k \ ka\ \ka \ Suc k\ \p < m\ card_AF_sum enum_DF_AF + by (simp add: enum_DF_AF less_list_def card_AF_sum LENS_def sum_sorted_list_of_set_map) + show "strict_sorted (LENS p)" + unfolding LENS_def + by (rule strict_sorted_acc_lengths) (use RF_non_Nil AF_non_Nil kka in \auto simp: in_lists_conv_set\) + show "strict_sorted LENS_QQ" + unfolding LENS_QQ_def QQ_def + by (rule strict_sorted_acc_lengths) (use RF_non_Nil AF_non_Nil kka in \auto simp: in_lists_conv_set\) + have last_AF_DF: "last (list_of (AF k p)) < \ (DF k q)" + using AF_DF [OF \p < q\, of k] AF_non_Nil [of k p] DF_ne [of k q] + by (metis Inf_nat_def1 finite_AF last_in_set less_sets_def set_sorted_list_of_set) + then show "list_of (AF k p) < LENS_QQ @ list_of (AF k q) @ ?INT" + by (simp add: less_list_def card_AF LENS_QQ_def) + show "LENS_QQ < list_of (AF k q) @ ?INT" + using AF_non_Nil [of k q] \q < m\ card_AF_sum enum_DF_AF card_AF_sum_QQ + by (auto simp: less_list_def AF_ne hd_append card_AF_sum LENS_QQ_def) + show "list_of (AF k q) < ?INT" + proof - + have "less_sets (AF k q) (RF (Suc 0) p)" + using \0 < k\ \p < m\ \q < m\ by (simp add: RF_def less_QF flip: QF_0) + then have "last (list_of (AF k q)) < hd (list_of (RF (Suc 0) p))" + proof (rule less_setsD) + show "last (list_of (AF k q)) \ AF k q" + using AF_non_Nil finite_AF last_in_set set_sorted_list_of_set by blast + show "hd (list_of (RF (Suc 0) p)) \ RF (Suc 0) p" + by (metis RF_non_Nil Suc_mono \0 < k\ finite_RF hd_in_set set_sorted_list_of_set) + qed + with \k > 0\ \ka \ 2\ RF_non_Nil show ?thesis + by (simp add: hd_interact less_list_def sorted_list_of_set_greaterThanLessThan PP_def QQ_def) + qed + qed auto + qed (auto simp: LENS_QQ_def) + show ?thesis + proof (cases "ka = k") + case True + then have "l = 2*k - 1" + by (simp add: kka(3) mult_2) + then show ?thesis + by (metis Form.intros(2) Form_Body_imp_inter_scheme True \0 < k\ \U = {x, y}\ kka zs zs_N) + next + case False + then have "l = 2*k" + using kka by linarith + then show ?thesis + by (metis False Form.intros(3) Form_Body_imp_inter_scheme \0 < k\ \U = {x, y}\ antisym kka le_SucE zs zs_N) + qed + qed + qed + qed +qed + + +subsection \Larson's Lemma 3.8\ + +subsubsection \Primitives needed for the inductive construction of @{term b}\ + +definition IJ where "IJ \ \k. Sigma {..k} (\j::nat. {.. IJ k \ (\j i. u = (j,i) \ i j\k)" + by (auto simp: IJ_def) + +lemma finite_IJ: "finite (IJ k)" + by (auto simp: IJ_def) + +fun prev where + "prev 0 0 = None" +| "prev (Suc 0) 0 = None" +| "prev (Suc j) 0 = Some (j, j - Suc 0)" +| "prev j (Suc i) = Some (j,i)" + +lemma prev_eq_None_iff: "prev j i = None \ j \ Suc 0 \ i = 0" + by (auto simp: le_Suc_eq elim: prev.elims) + +lemma prev_pair_less: + "prev j i = Some ji' \ (ji', (j,i)) \ pair_less" + by (auto simp: pair_lessI1 elim: prev.elims) + +lemma prev_Some_less: "\prev j i = Some (j',i'); i \ j\ \ i' < j'" + by (auto elim: prev.elims) + +lemma prev_maximal: + "\prev j i = Some (j',i'); (ji'', (j,i)) \ pair_less; ji'' \ IJ k\ + \ (ji'', (j',i')) \ pair_less \ ji'' = (j',i')" + by (force simp: IJ_def pair_less_def elim: prev.elims) + +lemma pair_less_prev: + assumes "(u, (j,i)) \ pair_less" "u \ IJ k" + shows "prev j i = Some u \ (\x. (u, x) \ pair_less \ prev j i = Some x)" +proof (cases "prev j i") + case None + show ?thesis + proof (cases u) + case (Pair j' i') + then show ?thesis + using assms None by (simp add: prev_eq_None_iff pair_less_def IJ_def) + qed +next + case (Some a) + then show ?thesis + by (metis assms prev_maximal prod.exhaust_sel) +qed + + + +subsubsection \Special primitives for the ordertype proof\ + +definition USigma :: "'a set set \ ('a set \ 'a set) \ 'a set set" + where "USigma \ B \ \X\\. \y\B X. {insert y X}" + +definition usplit + where "usplit f A \ f (A - {Max A}) (Max A)" + +lemma USigma_empty [simp]: "USigma {} B = {}" + by (auto simp: USigma_def) + +lemma USigma_iff: + assumes "\I j. I \ \ \ less_sets I (J I) \ finite I" + shows "x \ USigma \ J \ usplit (\I j. I\\ \ j\J I \ x = insert j I) x" +proof - + have [simp]: "\I j. \I \ \; j \ J I\ \ Max (insert j I) = j" + by (meson Max_insert2 assms less_imp_le less_sets_def) + show ?thesis + proof - + have "I - {j} \ \" if "I \ \" "j \ J I" for I j + using that by (metis Diff_empty Diff_insert0 assms less_irrefl less_sets_def) + moreover have "j \ J (I - {j})" if "I \ \" "j \ J I" for I j + using that by (metis Diff_empty Diff_insert0 assms less_irrefl less_setsD) + moreover have "\I\\. \j\J I. x = insert j I" + if "x - {Max x} \ \" and "Max x \ J (x - {Max x})" "x \ {}" + using that by (metis Max_in assms infinite_remove insert_Diff) + ultimately show ?thesis + by (auto simp: USigma_def usplit_def) + qed +qed + + +lemma ordertype_append_image_IJ: + assumes lenB [simp]: "\i j. i \ \ \ j \ J i \ length (B j) = c" + and AB: "\i j. i \ \ \ j \ J i \ A i < B j" + and IJ: "\i. i \ \ \ less_sets i (J i) \ finite i" + and \: "\i. i \ \ \ ordertype (B ` J i) (lenlex less_than) = \" + and A: "inj_on A \" + shows "ordertype (usplit (\i j. A i @ B j) ` USigma \ J) (lenlex less_than) + = \ * ordertype (A ` \) (lenlex less_than)" + (is "ordertype ?AB ?R = _ * ?\") +proof (cases "\ = {}") +next + case False + have "Ord \" + using \ False wf_Ord_ordertype by fastforce + show ?thesis + proof (subst ordertype_eq_iff) + define split where "split \ \l::nat list. (take (length l - c) l, (drop (length l - c) l))" + have oB: "ordermap (B ` J i) ?R (B j) \ \" if \i \ \\ \j \ J i\ for i j + using \ less_TC_iff that by fastforce + then show "Ord (\ * ?\)" + by (intro \Ord \\ wf_Ord_ordertype Ord_mult; simp) + define f where "f \ \u. let (x,y) = split u in let i = inv_into \ A x in + \ * ordermap (A`\) ?R x + ordermap (B`J i) ?R y" + have inv_into_IA [simp]: "inv_into \ A (A i) = i" if "i \ \" for i + by (simp add: A that) + show "\f. bij_betw f ?AB (elts (\ * ?\)) \ (\x\?AB. \y\?AB. (f x < f y) = ((x, y) \ ?R))" + unfolding bij_betw_def + proof (intro exI conjI strip) + show "inj_on f ?AB" + proof (clarsimp simp: f_def inj_on_def split_def USigma_iff IJ usplit_def) + fix x y + assume \
: "\ * ordermap (A ` \) ?R (A (x - {Max x})) + ordermap (B ` J (x - {Max x})) ?R (B (Max x)) + = \ * ordermap (A ` \) ?R (A (y - {Max y})) + ordermap (B ` J (y - {Max y})) ?R (B (Max y))" + and x: "x - {Max x} \ \" + and y: "y - {Max y} \ \" + and mx: "Max x \ J (x - {Max x})" + and "x = insert (Max x) x" + and my: "Max y \ J (y - {Max y})" + have "ordermap (A`\) ?R (A (x - {Max x})) = ordermap (A`\) ?R (A (y - {Max y}))" + and B_eq: "ordermap (B ` J (x - {Max x})) ?R (B (Max x)) = ordermap (B ` J (y - {Max y})) ?R (B (Max y))" + using mult_cancellation_lemma [OF \
] oB mx my x y by blast+ + then have "A (x - {Max x}) = A (y - {Max y})" + using x y by auto + then have "x - {Max x} = y - {Max y}" + by (metis x y inv_into_IA) + then show "A (x - {Max x}) = A (y - {Max y}) \ B (Max x) = B (Max y)" + using B_eq mx my by auto + qed + show "f ` ?AB = elts (\ * ?\)" + proof + show "f ` ?AB \ elts (\ * ?\)" + using \Ord \\ + apply (clarsimp simp add: f_def split_def USigma_iff IJ usplit_def) + by (metis Ord_mem_iff_less_TC TC_small add_mult_less image_eqI oB ordermap_in_ordertype trans_llt wf_Ord_ordertype wf_llt) + show "elts (\ * ?\) \ f ` ?AB" + proof (clarsimp simp: f_def split_def image_iff USigma_iff IJ usplit_def Bex_def elim!: elts_multE split: prod.split) + fix \ \ + assume \: "\ \ elts \" and \: "\ \ elts ?\" + have "\ \ ordermap (A ` \) (lenlex less_than) ` A ` \" + by (meson \ ordermap_surj subset_iff) + then obtain i where "i \ \" and yv: "\ = ordermap (A`\) ?R (A i)" + by blast + have "\ \ ordermap (B ` J i) (lenlex less_than) ` B ` J i" + by (metis (no_types) \ \ \i \ \\ in_mono ordermap_surj) + then obtain j where "j \ J i" and xu: "\ = ordermap (B`J i) ?R (B j)" + by blast + then have mji: "Max (insert j i) = j" + by (meson IJ Max_insert2 \i \ \\ less_imp_le less_sets_def) + have [simp]: "i - {j} = i" + using IJ \i \ \\ \j \ J i\ less_setsD by fastforce + show + "\l. (\K. K - {Max K} \ \ \ Max K \ J (K - {Max K}) \ + K = insert (Max K) K \ + l = A (K - {Max K}) @ B (Max K)) \ \ * \ + \ = + \ * + ordermap (A ` \) ?R (take (length l - c) l) + + ordermap (B ` J (inv_into \ A (take (length l - c) l))) + ?R (drop (length l - c) l)" + proof (intro conjI exI) + let ?ji = "insert j i" + show "A i @ B j = A (?ji - {Max ?ji}) @ B (Max ?ji)" + by (auto simp: mji) + qed (use \i \ \\ \j \ J i\ mji xu yv in auto) + qed + qed + next + fix p q + assume "p \ ?AB" and "q \ ?AB" + then obtain x y where peq: "p = A (x - {Max x}) @ B (Max x)" + and qeq: "q = A (y - {Max y}) @ B (Max y)" + and x: "x - {Max x} \ \" + and y: "y - {Max y} \ \" + and mx: "Max x \ J (x - {Max x})" + and my: "Max y \ J (y - {Max y})" + by (auto simp: USigma_iff IJ usplit_def) + let ?mx = "x - {Max x}" + let ?my = "y - {Max y}" + show "(f p < f q) \ ((p, q) \ ?R)" + proof + assume "f p < f q" + then + consider "ordermap (A`\) ?R (A (x - {Max x})) < ordermap (A`\) ?R (A (y - {Max y}))" + | "ordermap (A`\) ?R (A (x - {Max x})) = ordermap (A`\) ?R (A (y - {Max y}))" + "ordermap (B`J (x - {Max x})) ?R (B (Max x)) < ordermap (B`J (y - {Max y})) ?R (B (Max y))" + using x y mx my + by (auto dest: mult_cancellation_less simp: f_def split_def peq qeq oB) + then have "(A ?mx @ B (Max x), A ?my @ B (Max y)) \ ?R" + proof cases + case 1 + then have "(A ?mx, A ?my) \ ?R" + using x y + by (force simp: Ord_mem_iff_lt intro: converse_ordermap_mono) + then show ?thesis + using x y mx my lenB lenlex_append1 by blast + next + case 2 + then have "A ?mx = A ?my" + using \?my \ \\ \?mx \ \\ by auto + then have eq: "?mx = ?my" + by (metis \?my \ \\ \?mx \ \\ inv_into_IA) + then have "(B (Max x), B (Max y)) \ ?R" + using mx my 2 + by (force simp: Ord_mem_iff_lt intro: converse_ordermap_mono) + with 2 show ?thesis + by (simp add: eq irrefl_less_than) + qed + then show "(p,q) \ ?R" + by (simp add: peq qeq f_def split_def sorted_list_of_set_Un AB) + next + assume pqR: "(p,q) \ ?R" + then have \
: "(A ?mx @ B (Max x), A ?my @ B (Max y)) \ ?R" + using peq qeq by blast + then consider "(A ?mx, A ?my) \ ?R" | "A ?mx = A ?my \ (B (Max x), B (Max y)) \ ?R" + proof (cases "(A ?mx, A ?my) \ ?R") + case False + have False if "(A ?my, A ?mx) \ ?R" + by (metis \?my \ \\ \?mx \ \\ "\
" \(Max y) \ J ?my\ \(Max x) \ J ?mx\ lenB lenlex_append1 omega_sum_1_less order.asym that) + then have "A ?mx = A ?my" + by (meson False UNIV_I total_llt total_on_def) + then show ?thesis + using "\
" irrefl_less_than that(2) by auto + qed (use that in blast) + then have "\ * ordermap (A`\) ?R (A ?mx) + ordermap (B`J ?mx) ?R (B (Max x)) + < \ * ordermap (A`\) ?R (A ?my) + ordermap (B`J ?my) ?R (B (Max y))" + proof cases + case 1 + show ?thesis + proof (rule add_mult_less_add_mult) + show "ordermap (A`\) (lenlex less_than) (A ?mx) < ordermap (A`\) (lenlex less_than) (A ?my)" + by (simp add: "1" \?my \ \\ \?mx \ \\ ordermap_mono_less) + show "Ord (ordertype (A`\) ?R)" + using wf_Ord_ordertype by blast+ + show "ordermap (B ` J ?mx) ?R (B (Max x)) \ elts \" + using Ord_less_TC_mem \Ord \\ \?mx \ \\ \(Max x) \ J ?mx\ oB by blast + show "ordermap (B ` J ?my) ?R (B (Max y)) \ elts \" + using Ord_less_TC_mem \Ord \\ \?my \ \\ \(Max y) \ J ?my\ oB by blast + qed (use \?my \ \\ \?mx \ \\ \Ord \\ in auto) + next + case 2 + with \?mx \ \\ show ?thesis + using \(Max y) \ J ?my\ \(Max x) \ J ?mx\ ordermap_mono_less + by (metis (no_types, hide_lams) Kirby.add_less_cancel_left TC_small image_iff inv_into_IA trans_llt wf_llt y) + qed + then show "f p < f q" + using \?my \ \\ \?mx \ \\ \(Max y) \ J ?my\ \(Max x) \ J ?mx\ + by (auto simp: peq qeq f_def split_def AB) + qed + qed + qed auto +qed auto + + +subsubsection \The final part of 3.8, where two sequences are merged\ + +definition cconcat where [simp]: "cconcat x l \ if x=[] then l else concat x#l" + +inductive merge :: "[nat list list,nat list list,nat list list,nat list list] \ bool" + where Null: "merge as [] (cconcat as []) []" + | App: "\as1 \ []; bs1 \ []; + concat as1 < concat bs1; concat bs1 < concat as2; merge as2 bs2 as bs\ + \ merge (as1@as2) (bs1@bs2) (cconcat as1 as) (cconcat bs1 bs)" + +inductive_simps Null1 [simp]: "merge [] bs us vs" +inductive_simps Null2 [simp]: "merge as [] us vs" + +lemma merge_single: + "\concat as < concat bs; concat as \ []; concat bs \ []\ \ merge as bs [concat as] [concat bs]" + using merge.App [of as bs "[]" "[]"] + by (fastforce simp add: less_list_def) + +lemma merge_length1_nonempty: + assumes "merge as bs us vs" "as \ lists (- {[]})" + shows "us \ lists (- {[]})" + using assms by induction (auto simp: mem_lists_non_Nil) + +lemma merge_length2_nonempty: + assumes "merge as bs us vs" "bs \ lists (- {[]})" + shows "vs \ lists (- {[]})" + using assms by induction (auto simp: mem_lists_non_Nil) + +lemma merge_length1_gt_0: + assumes "merge as bs us vs" "as \ []" + shows "length us > 0" + using assms by induction auto + +lemma merge_length_le: + assumes "merge as bs us vs" + shows "length vs \ length us" + using assms by induction auto + +lemma merge_length_le_Suc: + assumes "merge as bs us vs" + shows "length us \ Suc (length vs)" + using assms by induction auto + +lemma merge_length_less2: + assumes "merge as bs us vs" + shows "length vs \ length as" + using assms +proof induction +case (App as1 bs1 as2 bs2 as bs) + then show ?case + by simp (metis One_nat_def Suc_eq_plus1 Suc_leI add.commute add_mono length_greater_0_conv) +qed auto + +lemma merge_preserves: + assumes "merge as bs us vs" + shows "concat as = concat us \ concat bs = concat vs" + using assms by induction auto + +lemma merge_interact: + assumes "merge as bs us vs" "strict_sorted (concat as)" "strict_sorted (concat bs)" + "bs \ lists (- {[]})" + shows "strict_sorted (interact us vs)" + using assms +proof induction + case (App as1 bs1 as2 bs2 as bs) + then have "concat bs1 < concat bs" "concat bs1 < concat as" and xx: "concat bs1 \ []" + using merge_preserves strict_sorted_append_iff by fastforce+ + then have "concat bs1 < interact as bs" + using App + apply (simp add: less_list_def del: concat_eq_Nil_conv) + by (metis (full_types) Un_iff \concat bs1 < concat as\ \concat bs1 < concat bs\ last_in_set list.set_sel(1) set_interact sorted_wrt_append strict_sorted_append_iff strict_sorted_interact_imp_concat strict_sorted_sorted_wrt xx) + with App show ?case + apply (simp add: strict_sorted_append_iff del: concat_eq_Nil_conv) + by (metis hd_append2 less_list_def xx) +qed auto + + +lemma acc_lengths_merge1: + assumes "merge as bs us vs" + shows "list.set (acc_lengths k us) \ list.set (acc_lengths k as)" + using assms +proof (induction arbitrary: k) + case (App as1 bs1 as2 bs2 as bs) + then show ?case + apply (simp add: acc_lengths_append acc_lengths.simps strict_sorted_append_iff length_concat_acc_lengths) + by (simp add: le_supI2 length_concat) +qed (auto simp: acc_lengths.simps length_concat_acc_lengths) + +lemma acc_lengths_merge2: + assumes "merge as bs us vs" + shows "list.set (acc_lengths k vs) \ list.set (acc_lengths k bs)" + using assms +proof (induction arbitrary: k) + case (App as1 bs1 as2 bs2 as bs) + then show ?case + apply (simp add: acc_lengths_append acc_lengths.simps strict_sorted_append_iff length_concat_acc_lengths) + by (simp add: le_supI2 length_concat) +qed (auto simp: acc_lengths.simps length_concat_acc_lengths) + +lemma length_hd_le_concat: + assumes "as \ []" shows "length (hd as) \ length (concat as)" + by (metis (no_types) add.commute assms concat.simps(2) le_add2 length_append list.exhaust_sel) + +lemma length_hd_merge2: + assumes "merge as bs us vs" + shows "length (hd bs) \ length (hd vs)" + using assms by induction (auto simp: length_hd_le_concat) + +lemma merge_less_sets_hd: + assumes "merge as bs us vs" "strict_sorted (concat as)" "strict_sorted (concat bs)" "bs \ lists (- {[]})" + shows "less_sets (list.set (hd us)) (list.set (concat vs))" + using assms +proof induction + case (App as1 bs1 as2 bs2 as bs) + then have \
: "less_sets (list.set (concat bs1)) (list.set (concat bs2))" + by (force simp: dest: strict_sorted_imp_less_sets)+ + have *: "less_sets (list.set (concat as1)) (list.set (concat bs1))" + using App by (metis concat_append strict_sorted_append_iff strict_sorted_imp_less_sets) + then have "less_sets (list.set (concat as1)) (list.set (concat bs))" + using App \
less_sets_trans merge_preserves + by (metis List.set_empty append_in_lists_conv le_zero_eq length_concat_ge length_greater_0_conv list.size(3) mem_lists_non_Nil) + with * App.hyps show ?case + by (fastforce simp add: less_sets_UN1 less_sets_UN2 less_sets_Un2) +qed auto + +lemma set_takeWhile: + assumes "strict_sorted (concat as)" "as \ lists (- {[]})" + shows "list.set (takeWhile (\x. x < y) as) = {x \ list.set as. x < y}" + using assms +proof (induction as) + case (Cons a as) + have *: "a < y" + if a: "a < concat as" "strict_sorted a" "strict_sorted (concat as)" "x < y" "x \ []" "x \ list.set as" + for x + proof - + have "last x \ list.set (concat as)" + using set_concat that(5) that(6) by fastforce + then have "last a < hd (concat as)" + using Cons.prems that by (auto simp: less_list_def) + also have "\ \ hd y" if "y \ []" + using that a + by (meson \last x \ list.set (concat as)\ dual_order.strict_trans less_list_def not_le sorted_hd_le strict_sorted_imp_sorted) + finally show ?thesis + by (simp add: less_list_def) + qed + then show ?case + using Cons by (auto simp: strict_sorted_append_iff) +qed auto + +proposition merge_exists: + assumes "strict_sorted (concat as)" "strict_sorted (concat bs)" + "as \ lists (- {[]})" "bs \ lists (- {[]})" + "hd as < hd bs" "as \ []" "bs \ []" + and disj: "\a b. \a \ list.set as; b \ list.set bs\ \ a bus vs. merge as bs us vs" + using assms +proof (induction "length as + length bs" arbitrary: as bs rule: less_induct) + case (less as bs) + obtain as1 as2 bs1 bs2 + where A: "as1 \ []" "bs1 \ []" "concat as1 < concat bs1" "concat bs1 < concat as2" + and B: "as = as1@as2" "bs = bs1@bs2" and C: "bs2 = [] \ (as2 \ [] \ hd as2 < hd bs2)" + proof + define as1 where "as1 \ takeWhile (\x. x < hd bs) as" + define as2 where "as2 \ dropWhile (\x. x < hd bs) as" + define bs1 where "bs1 \ if as2=[] then bs else takeWhile (\x. x < hd as2) bs" + define bs2 where "bs2 \ if as2=[] then [] else dropWhile (\x. x < hd as2) bs" + + have as1: "as1 = takeWhile (\x. last x < hd (hd bs)) as" + using less.prems by (auto simp: as1_def less_list_def cong: takeWhile_cong) + have as2: "as2 = dropWhile (\x. last x < hd (hd bs)) as" + using less.prems by (auto simp: as2_def less_list_def cong: dropWhile_cong) + + have hd_as2: "as2 \ [] \ \ hd as2 < hd bs" + using as2_def hd_dropWhile by metis + have hd_bs2: "bs2 \ [] \ \ hd bs2 < hd as2" + using bs2_def hd_dropWhile by metis + show "as1 \ []" + by (simp add: as1_def less.prems takeWhile_eq_Nil_iff) + show "bs1 \ []" + by (metis as2 bs1_def hd_as2 hd_in_set less.prems(7) less.prems(8) set_dropWhileD takeWhile_eq_Nil_iff) + show "bs2 = [] \ (as2 \ [] \ hd as2 < hd bs2)" + by (metis as2_def bs2_def hd_bs2 less.prems(8) list.set_sel(1) set_dropWhileD) + have AB: "less_sets (list.set A) (list.set B)" + if "A \ list.set as1" "B \ list.set bs" for A B + proof - + have "A \ list.set as" + using that by (metis as1 set_takeWhileD) + then have "sorted A" + by (metis concat.simps(2) concat_append less.prems(1) sorted_append split_list_last strict_sorted_imp_sorted) + moreover have "sorted (hd bs)" + by (metis concat.simps(2) hd_Cons_tl less.prems(2) less.prems(7) strict_sorted_append_iff strict_sorted_imp_sorted) + ultimately show ?thesis + using that + apply (clarsimp simp add: as1_def less.prems set_takeWhile less_list_iff_less_sets less_sets_def) + by (smt UN_I dual_order.strict_trans2 hd_concat less.prems(2) less.prems(4) less.prems(7) list.set_sel(1) mem_lists_non_Nil not_le set_concat sorted_hd_le strict_sorted_imp_sorted) + qed + show "as = as1@as2" + by (simp add: as1_def as2_def) + show "bs = bs1@bs2" + by (simp add: bs1_def bs2_def) + have "less_sets (list.set (concat as1)) (list.set (concat bs1))" + using AB set_takeWhileD by (fastforce simp add: as1_def bs1_def less_sets_UN1 less_sets_UN2) + then show "concat as1 < concat bs1" + by (rule less_sets_imp_list_less) + have "less_sets (list.set (concat bs1)) (list.set (concat as2))" if "as2 \ []" + proof (clarsimp simp add: bs1_def less_sets_UN1 less_sets_UN2 set_takeWhile less.prems) + fix A B + assume "A \ list.set as2" "B \ list.set bs" "B < hd as2" + with that show "less_sets (list.set B) (list.set A)" + using hd_as2 less.prems(1,2) + apply (clarsimp simp add: less_sets_def less_list_def) + apply (auto simp: as2_def) + apply (simp flip: as2_def) + by (metis UN_I \as = as1 @ as2\ concat.simps(2) concat_append dual_order.strict_trans2 hd_concat in_set_conv_decomp_last not_le set_concat sorted_hd_le sorted_le_last sorted_sorted_wrt sorted_wrt_append strict_sorted_imp_sorted that) + qed + then show "concat bs1 < concat as2" + by (simp add: bs1_def less_sets_imp_list_less) + qed + obtain cs ds where "merge as2 bs2 cs ds" + proof (cases "bs2 = []") + case True + show ?thesis + proof + show "merge as2 bs2 (cconcat as2 []) (cconcat bs2 [])" + by (simp add: True) + qed + next + have \: "length as2 + length bs2 < length as + length bs" + by (simp add: A B) + case False + moreover have "strict_sorted (concat as2)" "strict_sorted (concat bs2)" + "as2 \ lists (- {[]})" "bs2 \ lists (- {[]})" + "\a b. \a \ list.set as2; b \ list.set bs2\ \ a < b \ b < a" + using B less.prems strict_sorted_append_iff by auto + ultimately show ?thesis + using C less.hyps [OF \] False that by force + qed + then obtain cs where "merge (as1 @ as2) (bs1 @ bs2) (cconcat as1 cs) (cconcat bs1 ds)" + using A merge.App by blast + then show ?case + using B by blast +qed + +subsubsection \Actual proof of lemma 3.8\ + +text \Lemma 3.8 of Jean A. Larson, ibid.\ +proposition lemma_3_8: + assumes "infinite N" + obtains X where "X \ WW" "ordertype X (lenlex less_than) = \\\" + "\u. u \ [X]\<^bsup>2\<^esup> \ + \l. Form l u \ (l > 0 \ [enum N l] < inter_scheme l u \ List.set (inter_scheme l u) \ N)" +proof - + let ?LL = "lenlex less_than" + define bf where "bf \ \M q. wfrec pair_less (\f (j,i). + let R = (case prev j i of None \ M | Some u \ snd (f u)) + in grab R (q j i))" + + have bf_rec: "bf M q (j,i) = + (let R = (case prev j i of None \ M | Some u \ snd (bf M q u)) + in grab R (q j i))" for M q j i + by (subst (1) bf_def) (simp add: Let_def wfrec bf_def cut_apply prev_pair_less cong: conj_cong split: option.split) + + have infinite_bf [simp]: "infinite (snd (bf M q u)) = infinite M" for M q u + using wf_pair_less + proof (induction u rule: wf_induct_rule) + case (less u) + then show ?case + proof (cases u) + case (Pair j i) + with less.IH prev_pair_less show ?thesis + by (auto simp: bf_rec [of M q j i] split: option.split) + qed + qed + + have bf_less_sets: "less_sets (fst (bf M q ij)) (snd (bf M q ij))" if "infinite M" for M q ij + using wf_pair_less + proof (induction ij rule: wf_induct_rule) + case (less u) + then show ?case + proof (cases u) + case (Pair j i) + with less_sets_grab show ?thesis + by (simp add: bf_rec [of M q j i] less.IH prev_pair_less that split: option.split) + qed + qed + + have bf_subset: "fst (bf M q u) \ M \ snd (bf M q u) \ M" for M q u + using wf_pair_less + proof (induction u rule: wf_induct_rule) + case (less u) + show ?case + proof (cases u) + case (Pair j i) + then show ?thesis + apply (simp add: bf_rec [of M q j i] that split: option.split) + using fst_grab_subset less.IH prev_pair_less snd_grab_subset by blast + qed + qed + + have card_fst_bf: "finite (fst (bf M q (j,i))) \ card (fst (bf M q (j,i))) = q j i" if "infinite M" for M q j i + by (simp add: that bf_rec [of M q j i] split: option.split) + + have bf_cong: "bf M q u = bf M q' u" + if "snd u \ fst u" and eq: "\y x. \x\y; y\fst u\ \ q' y x = q y x" for M q q' u + using wf_pair_less that + proof (induction u rule: wf_induct_rule) + case (less u) + show ?case + proof (cases u) + case (Pair j i) + with less.prems show ?thesis + proof (clarsimp simp add: bf_rec [of M _ j i] split: option.split) + fix j' i' + assume *: "prev j i = Some (j',i')" + then have **: "((j', i'), u) \ pair_less" + by (simp add: Pair prev_pair_less) + moreover have "i' < j'" + using Pair less.prems by (simp add: prev_Some_less [OF *]) + moreover have "\x y. \x \ y; y \ j'\ \ q' y x = q y x" + using ** less.prems by (auto simp: pair_less_def Pair) + ultimately show "grab (snd (bf M q (j',i'))) (q j i) = grab (snd (bf M q' (j',i'))) (q j i)" + using less.IH by auto + qed + qed + qed + + define ediff where "ediff \ \D:: nat \ nat set. \j i. enum (D j) (Suc i) - enum (D j) i" + define F where "F \ \l (dl,a0::nat set,b0::nat \ nat \ nat set,M). + let (d,Md) = grab (nxt M (enum N (Suc (2 * Suc l)))) (Suc l) in + let (a,Ma) = grab Md (Min d) in + let Gb = bf Ma (ediff (dl(l := d))) in + let dl' = dl(l := d) in + (dl', a, fst \ Gb, snd (Gb(l, l-1)))" + define DF where "DF \ rec_nat (\i\{..<0}. {}, {}, \p. {}, N) F" + have DF_simps: "DF 0 = (\i\{..<0}. {}, {}, \p. {}, N)" + "DF (Suc l) = F l (DF l)" for l + by (auto simp: DF_def) + note cut_apply [simp] + + have inf [rule_format]: "\dl al bl L. DF l = (dl,al,bl,L) \ infinite L" for l + by (induction l) (auto simp: DF_simps F_def Let_def grab_eqD infinite_nxtN assms split: prod.split) + + define \ where + "\ \ \(dl, a, b :: nat \ nat \ nat set, M::nat set). \l::nat. + less_sets (dl l) a \ finite a \ dl l \ {} \ a \ {} \ + (\j\l. card (dl j) = Suc j) \ less_sets a (\(range b)) \ range b \ Collect finite \ + a \ N \ \(range b) \ N \ infinite M \ less_sets (b(l,l-1)) M \ + M \ N" + have \_DF: "\ (DF (Suc l)) l" for l + proof (induction l) + case 0 + show ?case + using assms + apply (clarsimp simp add: bf_rec F_def DF_simps \_def split: prod.split) + apply (drule grab_eqD, blast dest: grab_eqD infinite_nxtN)+ + apply (auto simp: less_sets_UN2 less_sets_grab card_fst_bf elim!: less_sets_weaken2) + apply (metis Min_in card_eq_0_iff greaterThan_iff le_inf_iff less_nat_zero_code n_not_Suc_n nxt_def subsetD) + using nxt_subset snd_grab_subset bf_subset by blast+ + next + case (Suc l) + then show ?case + using assms + unfolding Let_def DF_simps(2)[of "Suc l"] F_def \_def + apply (clarsimp simp add: bf_rec DF_simps split: prod.split) + apply (drule grab_eqD, metis grab_eqD infinite_nxtN)+ + apply (safe, simp_all add: less_sets_UN2 less_sets_grab card_fst_bf) + apply (meson less_sets_weaken2) + apply (metis (no_types, hide_lams) IntE Min_in card_empty greaterThan_iff leD not_less_eq_eq nxt_def subsetD zero_less_Suc) + apply (meson bf_subset less_sets_weaken2) + apply (meson nxt_subset subset_eq) + apply (meson bf_subset nxt_subset subset_eq) + using bf_rec infinite_bf apply force + using bf_less_sets bf_rec apply force + by (metis bf_rec bf_subset nxt_subset subsetD) + qed + + define d where "d \ \k. let (dk,ak,bk,M) = DF(Suc k) in dk k" + define a where "a \ \k. let (dk,ak,bk,M) = DF(Suc k) in ak" + define b where "b \ \k. let (dk,ak,bk,M) = DF(Suc k) in bk" + define M where "M \ \k. let (dk,ak,bk,M) = DF k in M" + + have infinite_M [simp]: "infinite (M k)" for k + by (auto simp: M_def inf split: prod.split) + + have M_Suc_subset: "M (Suc k) \ M k" for k + apply (clarsimp simp add: Let_def M_def F_def DF_simps split: prod.split) + apply (drule grab_eqD, blast dest: infinite_nxtN local.inf)+ + using bf_subset nxt_subset by blast + + have Inf_M_Suc_ge: "Inf (M k) \ Inf (M (Suc k))" for k + by (simp add: M_Suc_subset cInf_superset_mono infinite_imp_nonempty) + + have Inf_M_telescoping: "{Inf (M k)..} \ {Inf (M k')..}" if "k'\k" for k k' + using that + by (induction "k-k'")(auto simp: Inf_M_Suc_ge M_Suc_subset cInf_superset_mono infinite_imp_nonempty lift_Suc_antimono_le) + + have d_eq: "d k = fst (grab (nxt (M k) (enum N (Suc (2 * Suc k)))) (Suc k))" for k + by (simp add: d_def M_def Let_def DF_simps F_def split: prod.split) + then have finite_d [simp]: "finite (d k)" for k + by simp + then have d_ne [simp]: "d k \ {}" for k + by (metis card_empty card_grab d_eq infinite_M infinite_nxtN nat.distinct(1)) + have a_eq: "\M. a k = fst (grab M (Min (d k))) \ infinite M" for k + apply (simp add: a_def d_def M_def Let_def DF_simps F_def split: prod.split) + by (metis fst_conv grab_eqD infinite_nxtN local.inf) + then have card_a: "card (a k) = Inf (d k)" for k + by (metis cInf_eq_Min card_grab d_ne finite_d) + + have d_eq_dl: "d k = dl k" if "(dl,a,b,P) = DF l" "k < l" for k l dl a b P + using that + by (induction l arbitrary: dl a b P) (simp_all add: d_def DF_simps F_def Let_def split: prod.split_asm prod.split) + + have card_d [simp]: "card (d k) = Suc k" for k + by (auto simp: d_eq infinite_nxtN) + + have d_ne [simp]: "d j \ {}" and a_ne [simp]: "a j \ {}" + and finite_d [simp]: "finite (d j)" and finite_a [simp]: "finite (a j)" for j + using \_DF [of "j"] by (auto simp: \_def a_def d_def split: prod.split_asm) + + have da: "less_sets (d k) (a k)" for k + using \_DF [of "k"] by (simp add: \_def a_def d_def split: prod.split_asm) + + have ab_same: "less_sets (a k) (\(range(b k)))" for k + using \_DF [of "k"] + by (simp add: \_def a_def b_def M_def split: prod.split_asm) + + have snd_bf_subset: "snd (bf M r (j,i)) \ snd (bf M r (j',i'))" + if ji: "((j',i'), (j,i)) \ pair_less" "(j',i') \ IJ k" + for M r k j i j' i' + using wf_pair_less ji + proof (induction rule: wf_induct_rule [where a= "(j,i)"]) + case (less u) + show ?case + proof (cases u) + case (Pair j i) + then consider "prev j i = Some (j', i')" | x where "((j', i'), x) \ pair_less" "prev j i = Some x" + using less.prems pair_less_prev by blast + then show ?thesis + proof cases + case 1 + then show ?thesis + by (simp add: Pair bf_rec snd_grab_subset) + next + case 2 + then have "snd (bf M r x) \ snd (bf M r (j', i'))" + by (simp add: Pair less.IH prev_pair_less that(2)) + moreover have "snd (bf M r u) \ snd (bf M r x)" + by (simp add: 2 Pair bf_rec snd_grab_subset) + ultimately show ?thesis + by auto + qed + qed + qed + + have less_bf: "less_sets (fst (bf M r (j',i'))) (fst (bf M r (j,i)))" + if ji: "((j',i'), (j,i)) \ pair_less" "(j',i') \ IJ k" and "infinite M" + for M r k j i j' i' + proof - + consider "prev j i = Some (j', i')" | j'' i'' where "((j', i'), (j'',i'')) \ pair_less" "prev j i = Some (j'',i'')" + by (metis pair_less_prev ji prod.exhaust_sel) + then show ?thesis + proof cases + case 1 + then show ?thesis + using bf_less_sets bf_rec infinite_bf less_sets_fst_grab \infinite M\ by auto + next + case 2 + then have "less_sets (fst (bf M r (j',i'))) (snd (bf M r (j'',i'')))" + by (meson bf_less_sets snd_bf_subset less_sets_weaken2 that) + with 2 show ?thesis + using bf_rec infinite_bf less_sets_fst_grab \infinite M\ by auto + qed + qed + + have aM: "less_sets (a k) (M (Suc k))" for k + apply (clarsimp simp add: a_def M_def DF_simps F_def Let_def split: prod.split) + by (meson bf_subset grab_eqD infinite_nxtN less_sets_weaken2 local.inf) + then have "less_sets (a k) (a (Suc k))" for k + by (metis IntE card_d card_empty d_eq da fst_grab_subset less_sets_trans less_sets_weaken2 nat.distinct(1) nxt_def subsetI) + then have aa: "less_sets (a j) (a k)" if "jk" for k k' j i + by (metis a_ne ab_same le_less less_sets_UN2 less_sets_trans rangeI that) + have db: "less_sets (d j) (b k (j,i))" if "j\k" for k j i + by (meson a_ne ab da less_sets_trans that) + + have bMkk: "less_sets (b k (k,k-1)) (M (Suc k))" for k + using \_DF [of k] + by (simp add: \_def b_def d_def M_def split: prod.split_asm) + + have b: "\P \ M k. infinite P \ (\j i. i\j \ j\k \ b k (j,i) = fst (bf P (ediff d) (j,i)))" for k + proof (clarsimp simp: b_def DF_simps F_def Let_def split: prod.split) + fix a a' d' dl bb P M' M'' + assume gr: "grab M'' (Min d') = (a', M')" "grab (nxt P (enum N (Suc (Suc (Suc (2 * k)))))) (Suc k) = (d', M'')" + and DF: "DF k = (dl, a, bb, P)" + have deq: "d j = (if j = k then d' else dl j)" if "j\k" for j + proof (cases "j < k") + case True + then show ?thesis + by (metis DF d_eq_dl less_not_refl) + next + case False + then show ?thesis + using that DF gr + by (auto simp: d_def DF_simps F_def Let_def split: prod.split) + qed + have "M' \ P" + by (metis gr in_mono nxt_subset snd_conv snd_grab_subset subsetI) + also have "P \ M k" + using DF by (simp add: M_def) + finally have "M' \ M k" . + moreover have "infinite M'" + using DF by (metis (mono_tags) finite_grab_iff gr infinite_nxtN local.inf snd_conv) + moreover + have "ediff (dl(k := d')) j i = ediff d j i" if "j\k" for j i + by (simp add: deq that ediff_def) + then have "bf M' (ediff (dl(k := d'))) (j,i) + = bf M' (ediff d) (j,i)" if "i \ j" "j\k" for j i + using bf_cong that by fastforce + ultimately show "\P\M k. infinite P \ + (\j i. i \ j \ j \ k + \ fst (bf M' (ediff (dl(k := d'))) (j,i)) + = fst (bf P (ediff d) (j,i)))" + by auto + qed + + have card_b: "card (b k (j,i)) = enum (d j) (Suc i) - enum (d j) i" if "j\k" for k j i + \\there's a short proof of this from the previous result but it would need @{term"i\j"}\ + proof (clarsimp simp: b_def DF_simps F_def Let_def split: prod.split) + fix dl + and a a' d':: "nat set" + and bb M M' M'' + assume gr: "grab M'' (Min d') = (a', M')" "grab (nxt M (enum N (Suc (Suc (Suc (2 * k)))))) (Suc k) = (d',M'')" + and DF: "DF k = (dl, a, bb, M)" + have "d j = (if j = k then d' else dl j)" + proof (cases "j < k") + case True + then show ?thesis + by (metis DF d_eq_dl less_not_refl) + next + case False + then show ?thesis + using that DF gr by (auto simp: d_def DF_simps F_def Let_def split: prod.split) + qed + then show "card (fst (bf M' (ediff (dl(k := d'))) (j,i))) + = enum (d j) (Suc i) - enum (d j) i" + using DF gr card_fst_bf grab_eqD infinite_nxtN local.inf ediff_def by auto + qed + + have card_b_pos: "card (b k (j,i)) > 0" if "i < j" "j\k" for k j i + by (simp add: card_b that finite_enumerate_step) + have b_ne [simp]: "b k (j,i) \ {}" if "i < j" "j\k" for k j i + using card_b_pos [OF that] less_imp_neq by fastforce+ + + have card_b_finite [simp]: "finite (b k u)" for k u + using \_DF [of k] by (fastforce simp add: \_def b_def) + + have bM: "less_sets (b k (j,i)) (M (Suc k))" if "ik" for i j k + proof - + obtain M' where "M' \ M k" "infinite M'" + and bk: "\j i. i\j \ j\k \ b k (j,i) = fst (bf M' (ediff d) (j,i))" + using b by (metis (no_types, lifting)) + show ?thesis + proof (cases "j=k \ i = k-1") + case False + show ?thesis + proof (rule less_sets_trans [OF _ bMkk]) + show "less_sets (b k (j,i)) (b k (k, k - 1))" + using that \infinite M'\ False + by (force simp: bk pair_less_def IJ_def intro: less_bf) + show "b k (k, k - 1) \ {}" + using b_ne that by auto + qed + qed (use bMkk in auto) + qed + + have b_InfM: "\ (range (b k)) \ {\(M k)..}" for k + proof (clarsimp simp add: \_def b_def M_def DF_simps F_def Let_def split: prod.split) + fix r dl :: "nat \ nat set" + and a b and d' a' M'' M' P :: "nat set" + and x j' i' :: nat + assume gr: "grab M'' (Min d') = (a', M')" + "grab (nxt P (enum N (Suc (Suc (Suc (2 * k)))))) (Suc k) = (d', M'')" + and DF: "DF k = (dl, a, b, P)" + and x: "x \ fst (bf M' (ediff (dl(k := d'))) (j', i'))" + have "infinite P" + using DF local.inf by blast + then have "M' \ P" + by (meson gr grab_eqD infinite_nxtN nxt_subset order.trans) + with bf_subset show "\ P \ (x::nat)" + using Inf_nat_def x le_less_linear not_less_Least by fastforce + qed + + have b_Inf_M_Suc: "less_sets (b k (j,i)) {Inf(M (Suc k))}" if "ik" for k j i + using bMkk [of k] that + by (metis Inf_nat_def1 bM finite.emptyI infinite_M less_setsD less_sets_singleton2) + + have bb_same: "less_sets (b k (j',i')) (b k (j,i))" + if "((j',i'), (j,i)) \ pair_less" "(j',i') \ IJ k" for k j i j' i' + using that + unfolding b_def DF_simps F_def Let_def + by (auto simp: less_bf grab_eqD infinite_nxtN local.inf split: prod.split) + + have bb: "less_sets (b k' (j',i')) (b k (j,i))" + if j: "i' < j'" "j'\k'" and k: "k' {\(M k)..}" + by (rule order_trans [OF _ b_InfM]) auto + also have "\ \ {Inf(M (Suc k'))..}" + using Inf_M_telescoping k by auto + finally show "b k (j,i) \ {Inf(M (Suc k'))..}" . + qed + + have M_subset_N: "M k \ N" for k + proof (cases k) + case (Suc k') + with \_DF [of k'] show ?thesis + by (auto simp: M_def Let_def \_def split: prod.split) + qed (auto simp: M_def DF_simps) + have a_subset_N: "a k \ N" for k + using \_DF [of k] by (simp add: a_def \_def split: prod.split prod.split_asm) + have d_subset_N: "d k \ N" for k + using M_subset_N [of k] d_eq fst_grab_subset nxt_subset by blast + have b_subset_N: "b k (j,i) \ N" for k j i + using \_DF [of k] by (force simp: b_def \_def) + + define \:: "[nat,nat] \ nat set set" + where "\ \ \j0 j. nsets {j0<..} j" + + have \_finite: "K \ \ j0 j \ finite K" for K j0 j + by (simp add: \_def nsets_def) + have \_card: "K \ \ j0 j \ card K = j" for K j0 j + by (simp add: \_def nsets_def) + have \_enum: "j0 < enum K i" if "K \ \ j0 j" "i < card K" for K j0 j i + using that by (auto simp: \_def nsets_def finite_enumerate_in_set subset_eq) + have \_0 [simp]: "\ k 0 = {{}}" for k + by (auto simp: \_def) + + have \_Suc: "\ j0 (Suc j) = USigma (\ j0 j) (\K. {Max (insert j0 K)<..})" (is "?lhs = ?rhs") + for j j0 + proof + show "\ j0 (Suc j) \ USigma (\ j0 j) (\K. {Max (insert j0 K)<..})" + unfolding \_def nsets_def USigma_def + proof clarsimp + fix K + assume K: "K \ {j0<..}" "finite K" "card K = Suc j" + then obtain i where "Max (insert j0 (K - {Max K})) < i" "K = insert i (K - {Max K})" + apply (simp add: subset_iff) + by (metis Diff_iff Max.coboundedI Max_in card_0_eq insert_Diff insert_iff le_neq_implies_less nat.distinct(1)) + then show "\L\{j0<..}. finite L \ card L = j \ + (\i\{Max (insert j0 L)<..}. K = insert i L)" + using K + by (metis Max_in card_Diff_singleton_if card_gt_0_iff diff_Suc_1 finite_Diff greaterThan_iff insert_subset zero_less_Suc) + qed + show "?rhs \ \ j0 (Suc j)" + by (force simp: \_def nsets_def USigma_def) + qed + + define BB where "BB \ \j0 j K. list_of (a j0 \ (\i \j. BB j j ` \ j j" + + have less_list_of: "BB j i K < list_of (b l (j,i))" + if K: "K \ \ j i" "\j\K. j < l" and "i \ j" "j \ l" for j i K l + unfolding BB_def + proof (rule less_sets_imp_sorted_list_of_set) + have "\i. i < card K \ less_sets (b (enum K i) (j,i)) (b l (j, card K))" + using that by (metis \_card \_enum \_finite bb finite_enumerate_in_set nat_less_le less_le_trans) + then show "less_sets (a j \ (\i_def nsets_def + by (auto simp: less_sets_Un1 less_sets_UN1 ab finite_enumerate_in_set subset_eq) + qed auto + have BB_Suc: "BB j0 (Suc j) K = usplit (\L k. BB j0 j L @ list_of (b k (j0, j))) K" + if j: "j \ j0" and K: "K \ \ j0 (Suc j)" for j0 j K + \\towards the ordertype proof\ + proof - + have Kj: "K \ {j0<..}" and [simp]: "finite K" and cardK: "card K = Suc j" + using K by (auto simp: \_def nsets_def) + have KMK: "K - {Max K} \ \ j0 j" + using that by (simp add: \_Suc USigma_iff \_finite less_sets_def usplit_def) + have "j0 < Max K" + by (metis Kj Max_in cardK card_gt_0_iff greaterThan_iff subsetD zero_less_Suc) + have MaxK: "Max K = enum K j" + proof (rule Max_eqI) + show "enum K j \ K" + by (simp add: cardK finite_enumerate_in_set) + show "k \ enum K j" if "k \ K" for k + using that K + by (metis \finite K\ cardK enum_obtain_index_finite finite_enumerate_mono leI less_Suc_eq less_asym) + qed auto + have ene: "i enum (K - {enum K j}) i = enum K i" for i + using finite_enumerate_Diff_singleton [OF \finite K\] by (simp add: cardK) + have "BB j0 (Suc j) K = list_of ((a j0 \ (\x b (enum K j) (j0, j))" + by (simp add: BB_def lessThan_Suc Un_ac) + also have "\ = list_of ((a j0 \ (\i enum K i" + using that K by (metis \_enum cardK less_SucI less_imp_le_nat) + show "enum K i < enum K j" + by (simp add: cardK finite_enumerate_mono that) + qed + moreover have "less_sets (a j0) (b (enum K j) (j0, j))" + using MaxK \j0 < Max K\ ab by auto + ultimately show "less_sets (a j0 \ (\x = BB j0 j (K - {Max K}) @ list_of (b (Max K) (j0, j))" + by (simp add: BB_def MaxK ene) + also have "\ = usplit (\L k. BB j0 j L @ list_of (b k (j0, j))) K" + by (simp add: usplit_def) + finally show ?thesis . + qed + + have enum_d_0: "enum (d j) 0 = Inf (d j)" for j + using enum_0_eq_Inf_finite by auto + + have Inf_b_less: "\(b k' (j',i')) < \(b k (j,i))" + if j: "i' < j'" "i < j" "j'\k'" "j\k" and k: "k' (b k (k, k-1)) \ k-1" if "k>0" for k + using that + proof (induction k) + case (Suc k) + show ?case + proof (cases "k=0") + case False + have "\ (b k (k, k - Suc 0)) < \ (b (Suc k) (Suc k, k))" + using False Inf_b_less by auto + with False Suc show ?thesis + by simp + qed auto + qed auto + + have b_ge: "\ (b k (j,i)) \ k-1" if k: "k>0" "k \ j" and "j > i" for k j i + using k + proof (induction k) + case (Suc k) + show ?case + proof (cases "j \ k") + case True + have "\ (b k (j,i)) < \ (b (Suc k) (j,i))" + using \j > i\ Suc True by (force intro: Inf_b_less) + then show ?thesis + using Suc.IH True by linarith + next + case False + then have "j = Suc k" + using Suc.prems(2) by linarith + with \i < j\ have "i < Suc k" + by fastforce + moreover have "\ \ (b (Suc k) (j,i)) < \ (b (Suc k) (j,i))" + by fastforce + ultimately have "\ Suc (\ (b (Suc k) (j,i))) < Suc k" + by (metis Inf_b_less \j = Suc k\ b_ge_k diff_Suc_1 leD le_refl lessI zero_less_Suc) + then show ?thesis + by simp + qed + qed auto + + have hd_b: "hd (list_of (b k (j,i))) = \ (b k (j,i))" + if "i < j" "j \ k" for k j i + using that by (simp add: hd_list_of cInf_eq_Min) + + have b_disjoint_less: "b (enum K i) (j0, i) \ b (enum K i') (j0, i') = {}" + if K: "K \ {j0<..}" "finite K" "card K \ j0" "i' < j" "i < i'" "j \ j0" for i i' j j0 K + proof (intro bb less_sets_imp_disjnt [unfolded disjnt_def]) + show "i < j0" + using that by linarith + then show "j0 \ enum K i" + by (meson K finite_enumerate_in_set greaterThan_iff less_imp_le_nat less_le_trans subsetD) + show "enum K i < enum K i'" + using K \j \ j0\ that by auto + qed + + have b_disjoint: "b (enum K i) (j0, i) \ b (enum K i') (j0, i') = {}" + if K: "K \ {j0<..}" "finite K" "card K \ j0" "i < j" "i' < j" "i \ i'" "j \ j0" for i i' j j0 K + using that b_disjoint_less inf_commute neq_iff by metis + + have ot\: "ordertype ((\k. list_of (b k (j,i))) ` {Max (insert j K)<..}) ?LL = \" + (is "?lhs = _") + if K: "K \ \ j i" "j > i" for j i K + proof - + have Sucj: "Suc (Max (insert j K)) \ j" + using \_finite that(1) le_Suc_eq by auto + let ?N = "{Inf(b k (j,i))| k. Max (insert j K) < k}" + have infN: "infinite ?N" + proof (clarsimp simp add: infinite_nat_iff_unbounded_le) + fix m + show "\n\m. \k. n = \ (b k (j,i)) \ Max (insert j K) < k" + using b_ge [of _ j i] \j > i\ Sucj + by (metis (no_types, lifting) diff_Suc_1 le_SucI le_trans less_Suc_eq_le nat_le_linear zero_less_Suc) + qed + have [simp]: "Max (insert j K) < k \ j < k \ (\a\K. a < k)" for k + using that by (auto simp: \_finite) + have "?lhs = ordertype ?N less_than" + proof (intro ordertype_eqI strip) + have "list_of (b k (j,i)) = list_of (b k' (j,i))" + if "j \ k" "j \ k'" "hd (list_of (b k (j,i))) = hd (list_of (b k' (j,i)))" + for k k' + by (metis Inf_b_less \i < j\ hd_b nat_less_le not_le that) + moreover have "\k' j' i'. hd (list_of (b k (j,i))) = \ (b k' (j', i')) \ i' < j' \ j' \ k'" + if "j \ k" for k + using that \i < j\ hd_b less_imp_le_nat by blast + moreover have "\k'. hd (list_of (b k (j,i))) = \ (b k' (j,i)) \ j < k' \ (\a\K. a < k')" + if "j < k" "\a\K. a < k" for k + using that K hd_b less_imp_le_nat by blast + moreover have "\ (b k (j,i)) \ hd ` (\k. list_of (b k (j,i))) ` {Max (insert j K)<..}" + if "j < k" "\a\K. a < k" for k + using that K by (auto simp: hd_b image_iff) + ultimately + show "bij_betw hd ((\k. list_of (b k (j,i))) ` {Max (insert j K)<..}) {\ (b k (j,i)) |k. Max (insert j K) < k}" + by (auto simp: bij_betw_def inj_on_def) + next + fix ms ns + assume "ms \ (\k. list_of (b k (j,i))) ` {Max (insert j K)<..}" + and "ns \ (\k. list_of (b k (j,i))) ` {Max (insert j K)<..}" + with that obtain k k' where + ms: "ms = list_of (b k (j,i))" and ns: "ns = list_of (b k' (j,i))" + and "j < k" "j < k'" and lt_k: "\a\K. a < k" and lt_k': "\a\K. a < k'" + by (auto simp: \_finite) + then have len_eq [simp]: "length ns = length ms" + by (simp add: card_b) + have nz: "length ns \ 0" + using b_ne \i < j\ \j < k'\ ns by auto + show "(hd ms, hd ns) \ less_than \ (ms, ns) \ ?LL" + proof + assume "(hd ms, hd ns) \ less_than" + then show "(ms, ns) \ ?LL" + using that nz + by (fastforce simp add: lenlex_def \_finite card_b intro: hd_lex) + next + assume \
: "(ms, ns) \ ?LL" + then have "(list_of (b k' (j,i)), list_of (b k (j,i))) \ ?LL" + using less_asym ms ns omega_sum_1_less by blast + then show "(hd ms, hd ns) \ less_than" + using \j < k\ \j < k'\ Inf_b_less [of i j i j] ms ns + by (metis Cons_lenlex_iff \
len_eq b_ne card_b_finite diff_Suc_1 hd_Cons_tl hd_b length_Cons less_or_eq_imp_le less_than_iff linorder_neqE_nat sorted_list_of_set_eq_Nil_iff that(2)) + qed + qed auto + also have "\ = \" + using infN ordertype_nat_\ by blast + finally show ?thesis . + qed + + have ot\j: "ordertype (BB j0 j ` \ j0 j) ?LL = \\j" if "j \ j0" for j j0 + using that + proof (induction j) + case 0 + then show ?case + by (auto simp: XX_def) + next + case (Suc j) + then have ih: "ordertype (BB j0 j ` \ j0 j) ?LL = \ \ j" + by simp + have "j \ j0" + by (simp add: Suc.prems Suc_leD) + have inj_BB: "inj_on (BB j0 j) ([{j0<..}]\<^bsup>j\<^esup>)" + proof (clarsimp simp: inj_on_def BB_def nsets_def subset_iff sorted_list_of_set_Un less_sets_UN2) + fix X Y + assume X [rule_format]: "\t. t \ X \ j0 < t" + and Y [rule_format]: "\t. t \ Y \ j0 < t" + and "finite X" + and jeq: "j = card X" + and "finite Y" + and "card Y = card X" + and eq: "list_of (a j0 \ (\i (\in. \n < card X\ \ j0 \ enum X n" + using X \finite X\ finite_enumerate_in_set less_imp_le_nat by blast + have enumY: "\n. \n < card X\ \ j0 \ enum Y n" + by (simp add: Y \card Y = card X\ \finite Y\ finite_enumerate_in_set less_imp_le_nat) + have smX: "strict_mono_sets {..i. b (enum X i) (j0, i))" + and smY: "strict_mono_sets {..i. b (enum Y i) (j0, i))" + using Suc.prems \card Y = card X\ \finite X\ \finite Y\ bb enumX enumY jeq + by (auto simp: strict_mono_sets_def) + + have len_eq: "length ms = length ns" + if "(ms, ns) \ list.set (zip (map (list_of \ (\i. b (enum X i) (j0,i))) (list_of {.. (\i. b (enum Y i) (j0,i))) (list_of {.. card X" + for ms ns n + using that + by (induction n rule: nat.induct) (auto simp: card_b enumX enumY) + have "concat (map (list_of \ (\i. b (enum X i) (j0, i))) (list_of {.. (\i. b (enum Y i) (j0, i))) (list_of {.. (\i. b (enum X i) (j0, i))) (list_of {.. (\i. b (enum Y i) (j0, i))) (list_of {.. (b (enum X i) (j0,i))" + "Inf (b (enum Y i) (j0,i)) \ (b (enum Y i) (j0,i))" "i < j0" + using Inf_nat_def1 Suc.prems b_ne enumX enumY jeq that by auto + ultimately show ?thesis + by (metis Inf_b_less enumX enumY leI nat_less_le that) + qed + then show "X = Y" + by (simp add: \card Y = card X\ \finite X\ \finite Y\ finite_enum_ext) + qed + have BB_Suc': "BB j0 (Suc j) X = usplit (\L k. BB j0 j L @ list_of (b k (j0, j))) X" + if "X \ USigma (\ j0 j) (\K. {Max (insert j0 K)<..})" for X + using that + by (simp add: USigma_iff \_finite less_sets_def usplit_def \_Suc BB_Suc \j \ j0\) + have "ordertype (BB j0 (Suc j) ` \ j0 (Suc j)) ?LL + = ordertype + (usplit (\L k. BB j0 j L @ list_of (b k (j0, j))) ` USigma (\ j0 j) (\K. {Max (insert j0 K)<..})) ?LL" + by (simp add: BB_Suc' \_Suc) + also have "\ = \ * ordertype (BB j0 j ` \ j0 j) ?LL" + proof (rule ordertype_append_image_IJ) + fix L k + assume "L \ \ j0 j" and "k \ {Max (insert j0 L)<..}" + then have "j0 < k" and L: "\a. a \ L \ a < k" + by (simp_all add: \_finite) + then show "BB j0 j L < list_of (b k (j0, j))" + by (simp add: \L \ \ j0 j\ \j \ j0\ \_finite less_list_of) + next + show "inj_on (BB j0 j) (\ j0 j)" + by (simp add: \_def inj_BB) + next + fix L + assume L: "L \ \ j0 j" + then show "less_sets L {Max (insert j0 L)<..} \ finite L" + by (metis \_finite atLeast_Suc_greaterThan finite_insert less_sets_Suc_Max less_sets_weaken1 subset_insertI) + show "ordertype ((\i. list_of (b i (j0, j))) ` {Max (insert j0 L)<..}) ?LL = \" + using L Suc.prems Suc_le_lessD ot\ by blast + qed (auto simp: \_finite card_b) + also have "\ = \ \ ord_of_nat (Suc j)" + by (metis ih One_nat_def Ord_\ Ord_ord_of_nat oexp_1_right oexp_add one_V_def ord_of_nat.simps(1) ord_of_nat.simps(2) ord_of_nat_add plus_1_eq_Suc) + finally show ?case . + qed + + define seqs where "seqs \ \j0 j K. list_of (a j0) # (map (list_of \ (\i. b (enum K i) (j0,i))) (list_of {.. lists (- {[]})" + if K: "K \ \ j0 j" and "j \ j0" for K j j0 + proof - + have j0: "\i. i < card K \ j0 \ enum K i" and le_j0: "card K \ j0" + using finite_enumerate_in_set that unfolding \_def nsets_def by fastforce+ + show "BB j0 j K = concat (seqs j0 j K)" + using that unfolding BB_def \_def nsets_def seqs_def + by (fastforce simp: j0 ab bb less_sets_UN2 sorted_list_of_set_Un + strict_mono_sets_def sorted_list_of_set_UN_lessThan) + have "b (enum K i) (j0, i) \ {}" if "i < card K" for i + using j0 le_j0 less_le_trans that by simp + moreover have "card K = j" + using K \_card by blast + ultimately show "seqs j0 j K \ lists (- {[]})" + by (clarsimp simp: seqs_def) (metis card_b_finite sorted_list_of_set_eq_Nil_iff) + qed + + have BB_decomp: "\cs. BB j0 j K = concat cs \ cs \ lists (- {[]})" + if K: "K \ \ j0 j" and "j \ j0" for K j j0 + using BB_eq_concat_seqs seqs_ne K that(2) by blast + + have a_subset_M: "a k \ M k" for k + apply (clarsimp simp: a_def M_def DF_simps F_def Let_def split: prod.split_asm) + by (metis (no_types) fst_conv fst_grab_subset nxt_subset snd_conv snd_grab_subset subsetD) + have ba_Suc: "less_sets (b k (j,i)) (a (Suc k))" if "i < j" "j \ k" for i j k + by (meson a_subset_M bM less_sets_weaken2 nat_less_le that(1) that(2)) + have ba: "less_sets (b k (j,i)) (a r)" if "i < j" "j \ k" "k < r" for i j k r + by (metis Suc_lessI a_ne aa ba_Suc less_sets_trans that) + + have disjnt_ba: "disjnt (b k (j,i)) (a r)" if "i < j" "j \ k" for i j k r + proof (cases "k < r") + case True + then show ?thesis + by (simp add: ba less_sets_imp_disjnt that) + next + case False + then show ?thesis + proof - + have "less_sets (a r) (b k (j,i))" + by (metis False a_ne aa ab_same less_linear less_sets_UN2 less_sets_trans rangeI) + then show ?thesis + using disjnt_sym less_sets_imp_disjnt by blast + qed + qed + + have bb_disjnt: "disjnt (b k (j,i)) (b l (r,q))" + if "q < r" "i < j" "j \ k" "r \ l" "j < r" for i j q r k l + proof (cases "k=l") + case True + with that show ?thesis + by (force simp: pair_less_def IJ_def intro: bb_same less_sets_imp_disjnt) + next + case False + with that show ?thesis + by (metis bb less_sets_imp_disjnt disjnt_sym nat_neq_iff) + qed + + have sum_card_b: "(\i {j0<..}" "finite K" "card K \ j0" and "j \ j0" for j0 j K + using \j \ j0\ + proof (induction j) + case 0 + then show ?case + by auto + next + case (Suc j) + have dis: "disjnt (b (enum K j) (j0, j)) (\ii < j\ b_disjoint_less disjnt_def disjnt_sym less_Suc_eq that) + qed + have j0_less: "j0 < enum K j" + by (meson Suc.prems Suc_le_lessD finite_enumerate_in_set greaterThan_iff less_le_trans subsetD K) + have "(\ii = card (b (enum K j) (j0, j)) + enum (d j0) j - enum (d j0) 0" + using \Suc j \ j0\ by (simp add: Suc.IH split: nat_diff_split) + also have "\ = enum (d j0) (Suc j) - enum (d j0) 0" + using j0_less + apply (simp add: card_b split: nat_diff_split) + by (metis Suc.prems card_d finite_d finite_enumerate_step le_imp_less_Suc less_asym) + finally show ?case . + qed + + have card_UN_b: "card (\i {j0<..}" "finite K" "card K \ j0" and "j \ j0" for j0 j K + using that by (simp add: card_UN_disjoint sum_card_b b_disjoint) + + have len_BB: "length (BB j j K) = enum (d j) j" + if K: "K \ \ j j" and "j \ j" for j K + proof - + have dis_ab: "\i. i < j \ disjnt (a j) (b (enum K i) (j,i))" + using K \_card \_enum ab less_sets_imp_disjnt nat_less_le by blast + show ?thesis + using K unfolding BB_def \_def nsets_def + by (simp add: card_UN_b card_Un_disjnt dis_ab card_a cInf_le_finite finite_enumerate_in_set enum_0_eq_Inf_finite) + qed + + have "less_sets (d k) (d (Suc k))" for k + by (metis aM a_ne d_eq da less_sets_fst_grab less_sets_trans less_sets_weaken2 nxt_subset) + then have dd: "less_sets (d k') (d k)" if "k' < k" for k' k + by (meson UNIV_I d_ne less_sets_imp_strict_mono_sets strict_mono_sets_def that) + + show thesis + proof + show "(\ (range XX)) \ WW" + by (auto simp: XX_def BB_def WW_def) + show "ordertype (\ (range XX)) (?LL) = \ \ \" + using ot\j by (simp add: XX_def ordertype_\\) + next + fix U + assume U: "U \ [\ (range XX)]\<^bsup>2\<^esup>" + then obtain x y where Ueq: "U = {x,y}" and len_xy: "length x \ length y" + by (auto simp: lenlex_nsets_2_eq lenlex_length) + + show "\l. Form l U \ (0 < l \ [enum N l] < inter_scheme l U \ list.set (inter_scheme l U) \ N)" + proof (cases "length x = length y") + case True + then show ?thesis + using Form.intros(1) U Ueq by fastforce + next + case False + then have xy: "length x < length y" + using len_xy by auto + obtain j r K L where K: "K \ \ j j" and xeq: "x = BB j j K" + and ne: "BB j j K \ BB r r L" + and L: "L \ \ r r" and yeq: "y = BB r r L" + using U by (auto simp: Ueq XX_def) + then have "length x = enum (d j) j" "length y = enum (d r) r" + by (auto simp: len_BB) + then have "j < r" + using xy dd + by (metis card_d finite_enumerate_in_set finite_d lessI less_asym less_setsD linorder_neqE_nat) + then have aj_ar: "less_sets (a j) (a r)" + using aa by auto + have Ksub: "K \ {j<..}" and "finite K" "card K \ j" + using K by (auto simp: \_def nsets_def) + have Lsub: "L \ {r<..}" and "finite L" "card L \ r" + using L by (auto simp: \_def nsets_def) + have enumK: "enum K i > j" if "i < j" for i + using K \_card \_enum that by blast + have enumL: "enum L i > r" if "i < r" for i + using L \_card \_enum that by blast + have "list.set (acc_lengths w (seqs j0 j K)) \ (+) w ` d j0" + if K: "K \ {j0<..}" "finite K" "card K \ j0" and "j \ j0" for j0 j K w + using \j \ j0\ + proof (induction j arbitrary: w) + case 0 + then show ?case + by (simp add: seqs_def acc_lengths.simps Inf_nat_def1 card_a) + next + case (Suc j) + let ?db = "\ (d j0) + ((\i d j0" + using Suc.prems finite_enumerate_in_set by (auto simp: finite_enumerate_in_set) + moreover have "list.set (acc_lengths w (seqs j0 j K)) \ (+) w ` d j0" + by (simp add: Suc Suc_leD) + then have "list.set (acc_lengths (w + \ (d j0)) + (map (list_of \ (\i. b (enum K i) (j0,i))) (list_of {.. (+) w ` d j0" + by (simp add: seqs_def acc_lengths.simps card_a subset_insertI) + ultimately show ?case + by (simp add: seqs_def acc_lengths.simps acc_lengths_append image_iff Inf_nat_def1 + sum_sorted_list_of_set_map card_a) + qed + then have acc_lengths_subset_d: "list.set (acc_lengths 0 (seqs j0 j K)) \ d j0" + if K: "K \ {j0<..}" "finite K" "card K \ j0" and "j \ j0" for j0 j K + by (metis image_add_0 that) + + have "strict_sorted x" "strict_sorted y" + by (auto simp: xeq yeq BB_def) + have disjnt_xy: "disjnt (list.set x) (list.set y)" + proof - + have "disjnt (a j) (a r)" + using \j < r\ aa less_sets_imp_disjnt by blast + moreover have "disjnt (b (enum K i) (j,i)) (a r)" if "i < j" for i + by (simp add: disjnt_ba enumK less_imp_le_nat that) + moreover have "disjnt (a j) (b (enum L q) (r,q))" if "q < r" for q + by (meson disjnt_ba disjnt_sym enumL less_imp_le_nat that) + moreover have "disjnt (b (enum K i) (j,i)) (b (enum L q) (r,q))" if "i < j" "q < r" for i q + by (meson \j < r\ bb_disjnt enumK enumL less_imp_le that) + ultimately show ?thesis + by (simp add: xeq yeq BB_def) + qed + have "\us vs. merge (seqs j j K) (seqs r r L) us vs" + proof (rule merge_exists) + show "strict_sorted (concat (seqs j j K))" + using BB_eq_concat_seqs K \strict_sorted x\ xeq by auto + show "strict_sorted (concat (seqs r r L))" + using BB_eq_concat_seqs L \strict_sorted y\ yeq by auto + show "seqs j j K \ lists (- {[]})" "seqs r r L \ lists (- {[]})" + by (auto simp: K L seqs_ne) + show "hd (seqs j j K) < hd (seqs r r L)" + by (simp add: aj_ar less_sets_imp_list_less seqs_def) + show "seqs j j K \ []" "seqs r r L \ []" + using seqs_def by blast+ + have less_bb: "less_sets (b (enum K i) (j,i)) (b (enum L p) (r, p))" + if neg: "\ less_sets (b (enum L p) (r, p)) (b (enum K i) (j,i))" and "i < j" "p < r" + for i p + proof (cases "enum K i" "enum L p" rule: linorder_cases) + case less + then show ?thesis + by (simp add: bb enumK less_imp_le_nat \i < j\) + next + case equal + then show ?thesis + using \j < r\ enumK \i < j\ by (force simp: IJ_iff pair_less_def intro: bb_same) + next + case greater + then show ?thesis + using bb enumL less_imp_le_nat neg \p < r\ by blast + qed + show "u < v \ v < u" + if "u \ list.set (seqs j j K)" and "v \ list.set (seqs r r L)" for u v + using that enumK enumL + apply (auto simp: seqs_def aj_ar intro!: less_bb less_sets_imp_list_less) + apply (meson ab ba less_imp_le_nat not_le)+ + done + qed + then obtain uus vvs where merge: "merge (seqs j j K) (seqs r r L) uus vvs" + by metis + then have "uus \ []" + using merge_length1_gt_0 by (auto simp: seqs_def) + then obtain u1 us where us: "u1#us = uus" + by (metis neq_Nil_conv) + define ku where "ku \ length (u1#us)" + define ps where "ps \ acc_lengths 0 (u1#us)" + have us_ne: "u1#us \ lists (- {[]})" + using merge_length1_nonempty seqs_ne us merge us K by auto + have xu_eq: "x = concat (u1#us)" + using BB_eq_concat_seqs K merge merge_preserves us xeq by auto + then have "strict_sorted u1" + using \strict_sorted x\ strict_sorted_append_iff by auto + have u_sub: "list.set ps \ list.set (acc_lengths 0 (seqs j j K))" + using acc_lengths_merge1 merge ps_def us by blast + have "vvs \ []" + using merge BB_eq_concat_seqs L merge_preserves xy yeq by auto + then obtain v1 vs where vs: "v1#vs = vvs" + by (metis neq_Nil_conv) + define kv where "kv \ length (v1#vs)" + define qs where "qs \ acc_lengths 0 (v1#vs)" + have vs_ne: "v1#vs \ lists (- {[]})" + using L merge merge_length2_nonempty seqs_ne vs by auto + have yv_eq: "y = concat (v1#vs)" + using BB_eq_concat_seqs L merge merge_preserves vs yeq by auto + then have "strict_sorted v1" + using \strict_sorted y\ strict_sorted_append_iff by auto + have v_sub: "list.set qs \ list.set (acc_lengths 0 (seqs r r L))" + using acc_lengths_merge2 merge qs_def vs by blast + + have ss_concat_jj: "strict_sorted (concat (seqs j j K))" + using BB_eq_concat_seqs K \strict_sorted x\ xeq by auto + then obtain k: "0 < kv" "kv \ ku" "ku \ Suc kv" "kv \ Suc j" + using us vs merge_length_le merge_length_le_Suc merge_length_less2 merge + unfolding ku_def kv_def by fastforce + + define zs where "zs \ concat [ps,u1,qs,v1] @ interact us vs" + have ss: "strict_sorted zs" + proof - + have ssp: "strict_sorted ps" + unfolding ps_def by (meson strict_sorted_acc_lengths us_ne) + have ssq: "strict_sorted qs" + unfolding qs_def by (meson strict_sorted_acc_lengths vs_ne) + + have "less_sets (d j) (list.set x)" + using da [of j] db [of j] K \_card \_enum nat_less_le + by (auto simp: xeq BB_def less_sets_Un2 less_sets_UN2) + then have ac_x: "acc_lengths 0 (seqs j j K) < x" + by (meson Ksub \finite K\ \j \ card K\ acc_lengths_subset_d dual_order.refl less_sets_imp_list_less less_sets_weaken1) + then have "ps < u1" + by (metis K Ksub UnI1 \_card \finite K\ \j \ card K\ \less_sets (d j) (list.set x)\ acc_lengths_subset_d concat.simps(2) empty_iff empty_set hd_append2 less_list_def less_sets_imp_list_less less_sets_weaken1 list.set_sel(1) set_append u_sub xu_eq) + + have "less_sets (d r) (list.set y)" + using da [of r] db [of r] L \_card \_enum nat_less_le + by (auto simp: yeq BB_def less_sets_Un2 less_sets_UN2) + then have "acc_lengths 0 (seqs r r L) < y" + by (meson Lsub \finite L\ \r \ card L\ acc_lengths_subset_d dual_order.refl less_sets_imp_list_less less_sets_weaken1) + then have "qs < v1" + by (metis L Lsub UnI1 \_card \finite L\ \r \ card L\ \less_sets (d r) (list.set y)\ acc_lengths_subset_d concat.simps(2) empty_iff empty_set hd_append2 less_list_def less_sets_imp_list_less less_sets_weaken1 list.set_sel(1) set_append v_sub yv_eq) + + have carda_v1: "card (a r) \ length v1" + using length_hd_merge2 [OF merge] unfolding vs [symmetric] by (simp add: seqs_def) + have ab_enumK: "\i. i < j \ less_sets (a j) (b (enum K i) (j,i))" + by (meson ab enumK le_trans less_imp_le_nat) + + have ab_enumL: "\q. q < r \ less_sets (a j) (b (enum L q) (r,q))" + by (meson \j < r\ ab enumL le_trans less_imp_le_nat) + then have ay: "less_sets (a j) (list.set y)" + by (auto simp: yeq BB_def less_sets_Un2 less_sets_UN2 aj_ar) + + have disjnt_hd_last_K_y: "disjnt {hd l..last l} (list.set y)" + if l: "l \ list.set (seqs j j K)" for l + proof (clarsimp simp add: yeq BB_def disjnt_iff Ball_def, intro conjI strip) + fix u + assume u: "u \ last l" and "hd l \ u" + with l consider "u \ last (list_of (a j))" "hd (list_of (a j)) \ u" + | i where "i last (list_of (b (enum K i) (j,i)))" "hd (list_of (b (enum K i) (j,i))) \ u" + by (force simp: seqs_def) + note l_cases = this + then show "u \ a r" + proof cases + case 1 + then show ?thesis + by (metis a_ne aj_ar finite_a last_in_set leD less_setsD set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff) + next + case 2 + then show ?thesis + by (metis enumK ab ba Inf_nat_def1 b_ne card_b_finite hd_b last_in_set less_asym less_setsD not_le set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff) + qed + fix q + assume "q < r" + show "u \ b (enum L q) (r,q)" using l_cases + proof cases + case 1 + then show ?thesis + by (metis \q < r\ a_ne ab_enumL finite_a last_in_set leD less_setsD set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff) + next + case 2 + show ?thesis + proof (cases "enum K i = enum L q") + case True + then show ?thesis + using 2 bb_same [of concl: "enum L q" j i r q] \j < r\ + apply (simp add: IJ_def pair_less_def less_sets_def) + by (metis enumK b_ne card_b_finite last_in_set leD less_imp_le_nat set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff) + next + case False + with 2 bb enumK enumL show ?thesis + unfolding less_sets_def + by (metis \q < r\ b_ne card_b_finite last_in_set leD less_imp_le_nat list.set_sel(1) nat_neq_iff set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff) + qed + qed + qed + + have u1_y: "less_sets (list.set u1) (list.set y)" + using vs yv_eq L \strict_sorted y\ merge merge_less_sets_hd merge_preserves seqs_ne ss_concat_jj us by fastforce + have u1_subset_seqs: "list.set u1 \ list.set (concat (seqs j j K))" + using merge_preserves [OF merge] us by auto + + have "less_sets (b k (j,i)) (d (Suc k))" if "j\k" "ik" "i list.set u1" for n + proof - + obtain l where l: "l \ list.set (seqs j j K)" and n: "n \ list.set l" + using n u1_subset_seqs by auto + then consider "l = list_of (a j)" | i where "l = list_of (b (enum K i) (j,i))" "i < j" + by (force simp: seqs_def) + then show ?thesis + proof cases + case 1 + then show ?thesis + by (metis Inf_nat_def1 \j < r\ ad d_ne finite_a less_setsD n set_sorted_list_of_set) + next + case 2 + then have "Min (b (enum K i) (j,i)) \ n" + using n by (simp add: less_list_def disjnt_iff less_sets_def) + also have f8: "n < hd y" + using less_setsD that u1_y + by (metis gr_implies_not0 list.set_sel(1) list.size(3) xy) + finally have "l < y" + using 2 disjnt_hd_last_K_y [OF l] u1_y + apply (simp add: less_list_def disjnt_iff) + by (metis card_b_finite hd_list_of leI less_imp_le_nat list.set_sel(1)) + moreover have "last (list_of (b (enum K i) (j,i))) < hd (list_of (a r))" + using \l < y\ L n by (auto simp: 2yeq BB_eq_concat_seqs seqs_def less_list_def) + then have "enum K i < r" + by (metis "2"(1) a_ne ab card_b_finite empty_iff finite.emptyI finite_a last_in_set leI less_asym less_setsD list.set_sel(1) n set_sorted_list_of_set) + moreover have "j \ enum K i" + by (simp add: "2"(2) enumK less_imp_le_nat) + ultimately show ?thesis + using 2 n bd [of j "enum K i" i r] Inf_nat_def1 less_setsD by force + qed + qed + then have "last u1 < Inf (d r)" + using \uus \ []\ us_ne by auto + also have "\ \ length v1" + using card_a carda_v1 by auto + finally have "last u1 < length v1" . + then have "u1 < qs" + by (simp add: qs_def acc_lengths.simps less_list_def) + + have "strict_sorted (interact (u1#us) (v1#vs))" + using L \strict_sorted x\ \strict_sorted y\ merge merge_interact merge_preserves seqs_ne us vs xu_eq yv_eq by auto + then have "strict_sorted (interact us vs)" "v1 < interact us vs" + by (auto simp: strict_sorted_append_iff) + moreover have "ps < u1 @ qs @ v1 @ interact us vs" + using \ps < u1\ us_ne unfolding less_list_def by auto + moreover have "u1 < qs @ v1 @ interact us vs" + by (metis \u1 < qs\ \vvs \ []\ acc_lengths_eq_Nil_iff hd_append less_list_def qs_def vs) + moreover have "qs < v1 @ interact us vs" + using \qs < v1\ us_ne \last u1 < length v1\ vs_ne by (auto simp: less_list_def) + ultimately show ?thesis + by (simp add: zs_def strict_sorted_append_iff ssp ssq \strict_sorted u1\ \strict_sorted v1\) + qed + have ps_subset_d: "list.set ps \ d j" + using K Ksub \_card \finite K\ acc_lengths_subset_d u_sub by blast + have ps_less_u1: "ps < u1" + proof - + have "hd u1 = hd x" + using us_ne by (auto simp: xu_eq) + then have "hd u1 \ a j" + by (simp add: xeq BB_eq_concat_seqs K seqs_def hd_append hd_list_of) + then have "less_sets (list.set ps) {hd u1}" + by (metis da ps_subset_d less_sets_def singletonD subset_iff) + then show ?thesis + by (metis less_hd_imp_less list.set(2) empty_set less_sets_imp_list_less) + qed + have qs_subset_d: "list.set qs \ d r" + using L Lsub \_card \finite L\ acc_lengths_subset_d v_sub by blast + have qs_less_v1: "qs < v1" + proof - + have "hd v1 = hd y" + using vs_ne by (auto simp: yv_eq) + then have "hd v1 \ a r" + by (simp add: yeq BB_eq_concat_seqs L seqs_def hd_append hd_list_of) + then have "less_sets (list.set qs) {hd v1}" + by (metis da qs_subset_d less_sets_def singletonD subset_iff) + then show ?thesis + by (metis less_hd_imp_less list.set(2) empty_set less_sets_imp_list_less) + qed + have FB: "Form_Body ku kv x y zs" + unfolding Form_Body.simps + using ku_def kv_def ps_def qs_def ss us_ne vs_ne xu_eq xy yv_eq zs_def by blast + then have "zs = (inter_scheme ((ku+kv) - Suc 0) {x,y})" + by (simp add: Form_Body_imp_inter_scheme k) + obtain l where "l \ 2 * (Suc j)" and l: "Form l U" and zs_eq_interact: "zs = inter_scheme l {x,y}" + proof + show "ku+kv-1 \ 2 * (Suc j)" + using k by auto + show "Form (ku+kv-1) U" + proof (cases "ku=kv") + case True + then show ?thesis + using FB Form.simps Ueq \0 < kv\ by (auto simp: mult_2) + next + case False + then have "ku = Suc kv" + using k by auto + then show ?thesis + using FB Form.simps Ueq \0 < kv\ by auto + qed + show "zs = inter_scheme (ku + kv - 1) {x, y}" + using Form_Body_imp_inter_scheme by (simp add: FB k) + qed + then have "enum N l \ enum N (Suc (2 * Suc j))" + by (simp add: assms less_imp_le_nat) + also have "\ < Min (d j)" + by (metis Min_in card_0_eq card_d d_eq finite_d fst_grab_subset greaterThan_iff in_mono le_inf_iff nxt_def old.nat.distinct(2)) + finally have ls: "less_sets {enum N l} (d j)" + by simp + have "l > 0" + by (metis l False Form_0_cases_raw Set.doubleton_eq_iff Ueq gr0I) + show ?thesis + unfolding Ueq + proof (intro exI conjI impI) + have zs_subset: "list.set zs \ list.set (acc_lengths 0 (seqs j j K)) \ list.set (acc_lengths 0 (seqs r r L)) \ list.set x \ list.set y" + using u_sub v_sub by (auto simp: zs_def xu_eq yv_eq) + also have "\ \ N" + proof (simp, intro conjI) + show "list.set (acc_lengths 0 (seqs j j K)) \ N" + using d_subset_N Ksub \finite K\ \j \ card K\ acc_lengths_subset_d by blast + show "list.set (acc_lengths 0 (seqs r r L)) \ N" + using d_subset_N Lsub \finite L\ \r \ card L\ acc_lengths_subset_d by blast + show "list.set x \ N" "list.set y \ N" + by (simp_all add: xeq yeq BB_def a_subset_N UN_least b_subset_N) + qed + finally show "list.set (inter_scheme l {x, y}) \ N" + using zs_eq_interact by blast + have "[enum N l] < ps" + using ps_subset_d ls + by (metis empty_set less_sets_imp_list_less less_sets_weaken2 list.simps(15)) + then show "[enum N l] < inter_scheme l {x, y}" + by (simp add: zs_def less_list_def ps_def flip: zs_eq_interact) + qed (use Ueq l in blast) + qed + qed +qed + + + + +subsection \The main partition theorem for @{term "\\\"}\ + +definition iso_ll where "iso_ll A B \ iso (lenlex less_than \ (A\A)) (lenlex less_than \ (B\B))" + +corollary ordertype_eq_ordertype_iso_ll: + assumes "Field (Restr (lenlex less_than) A) = A" "Field (Restr (lenlex less_than) B) = B" + shows "(ordertype A (lenlex less_than) = ordertype B (lenlex less_than)) + \ (\f. iso_ll A B f)" +proof - + have "total_on A (lenlex less_than) \ total_on B (lenlex less_than)" + by (meson UNIV_I total_lenlex total_on_def total_on_less_than) + then show ?thesis + by (simp add: assms wf_lenlex lenlex_transI iso_ll_def ordertype_eq_ordertype_iso_Restr) +qed + +theorem partition_\\_aux: + assumes "\ \ elts \" + shows "partn_lst (lenlex less_than) WW [\\\,\] 2" (is "partn_lst ?R WW [\\\,\] 2") +proof (cases "\ \ 1") + case True + then show ?thesis + using strict_sorted_into_WW unfolding WW_def by (auto intro!: partn_lst_triv1[where i=1]) +next + case False + obtain m where m: "\ = ord_of_nat m" + using assms elts_\ by auto + then have "m>1" + using False by auto + show ?thesis + unfolding partn_lst_def + proof clarsimp + fix f + assume f: "f \ [WW]\<^bsup>2\<^esup> \ {..: "?P0 \ ?P1" + proof (rule disjCI) + assume not1: "\ ?P1" + have "\W'. ordertype W' ?R = \\n \ f ` [W']\<^bsup>2\<^esup> \ {0} \ W' \ WW_seg (n*m)" for n::nat + proof - + have fnm: "f \ [WW_seg (n*m)]\<^bsup>2\<^esup> \ {..\n, ord_of_nat m] 2" + using ordertype_WW_seg [of "n*m"] + by (simp add: partn_lst_VWF_imp_partn_lst [OF Theorem_3_2]) + show ?thesis + using partn_lst_E [OF * fnm, simplified] + by (metis (no_types, hide_lams) One_nat_def Suc_1 WW_seg_subset_WW order.trans less_2_cases m not1 nth_Cons' nth_Cons_Suc) + qed + then obtain W':: "nat \ nat list set" + where otW': "\n. ordertype (W' n) ?R = \\n" + and f_W': "\n. f ` [W' n]\<^bsup>2\<^esup> \ {0}" + and seg_W': "\n. W' n \ WW_seg (n*m)" + by metis + define WW' where "WW' \ (\n. W' n)" + have "WW' \ WW" + using seg_W' WW_seg_subset_WW by (force simp: WW'_def) + with f have f': "f \ [WW']\<^bsup>2\<^esup> \ {..\\" + proof (rule antisym) + have "ordertype WW' ?R \ ordertype WW ?R" + by (simp add: \WW' \ WW\ lenlex_transI ordertype_mono wf_lenlex) + with ordertype_WW + show "ordertype WW' ?R \ \ \ \" + by simp + have "\ \ n \ ordertype (\ (range W')) ?R" for n::nat + by (metis TC_small UNIV_I UN_I otW' lenlex_transI ordertype_mono subsetI trans_less_than wf_lenlex wf_less_than) + then show "\ \ \ \ ordertype WW' ?R" + by (auto simp: elts_\ oexp_Limit ZFC_in_HOL.SUP_le_iff WW'_def) + qed + have FR_WW: "Field (Restr (lenlex less_than) WW) = WW" + by (simp add: Limit_omega_oexp Limit_ordertype_imp_Field_Restr ordertype_WW) + have FR_WW': "Field (Restr (lenlex less_than) WW') = WW'" + by (simp add: Limit_omega_oexp Limit_ordertype_imp_Field_Restr ot') + have FR_W: "Field (Restr (lenlex less_than) (WW_seg n)) = WW_seg n" if "n>0" for n + by (simp add: Limit_omega_oexp ordertype_WW_seg that Limit_ordertype_imp_Field_Restr) + have FR_W': "Field (Restr (lenlex less_than) (W' n)) = W' n" if "n>0" for n + by (simp add: Limit_omega_oexp otW' that Limit_ordertype_imp_Field_Restr) + have "\h. iso_ll (WW_seg n) (W' n) h" if "n>0" for n + proof (subst ordertype_eq_ordertype_iso_ll [symmetric]) + show "ordertype (WW_seg n) (lenlex less_than) = ordertype (W' n) (lenlex less_than)" + by (simp add: ordertype_WW_seg otW') + qed (auto simp: FR_W FR_W' that) + then obtain h_seg where h_seg: "\n. n > 0 \ iso_ll (WW_seg n) (W' n) (h_seg n)" + by metis + define h where "h \ \l. if l=[] then [] else h_seg (length l) l" + + have bij_h_seg: "\n. n > 0 \ bij_betw (h_seg n) (WW_seg n) (W' n)" + using h_seg by (simp add: iso_ll_def iso_iff2 FR_W FR_W') + have len_h_seg: "length (h_seg (length l) l) = length l * m" + if "length l > 0" "l \ WW" for l + using bij_betwE [OF bij_h_seg] seg_W' that by (simp add: WW_seg_def subset_iff) + have hlen: "length (h x) = length (h y) \ length x = length y" if "x \ WW" "y \ WW" for x y + using that \1 < m\ h_def len_h_seg by force + + have h: "iso_ll WW WW' h" + unfolding iso_ll_def iso_iff2 FR_WW FR_WW' + proof (intro conjI strip) + have W'_ne: "W' n \ {}" for n + using otW' [of n] by auto + then have "[] \ WW'" + using seg_W' [of 0] by (auto simp: WW'_def WW_seg_def) + let ?g = "\l. if l=[] then l else inv_into (WW_seg (length l div m)) (h_seg (length l div m)) l" + have h_seg_iff: "\n a b. \a \ WW_seg n; b \ WW_seg n; n>0\ \ + (a, b) \ lenlex less_than \ + (h_seg n a, h_seg n b) \ lenlex less_than \ h_seg n a \ W' n \ h_seg n b \ W' n" + using h_seg by (auto simp: iso_ll_def iso_iff2 FR_W FR_W') + + show "bij_betw h WW WW'" + unfolding bij_betw_iff_bijections + proof (intro exI conjI ballI) + fix l + assume "l \ WW" + then have l: "l \ WW_seg (length l)" + by (simp add: WW_seg_def) + have "h l \ W' (length l)" + proof (cases "l=[]") + case True + with seg_W' [of 0] W'_ne show ?thesis + by (auto simp: WW_seg_def h_def) + next + case False + then show ?thesis + using bij_betwE bij_h_seg h_def l by fastforce + qed + show "h l \ WW'" + using WW'_def \h l \ W' (length l)\ by blast + show "?g (h l) = l" + proof (cases "l=[]") + case False + then have "length l > 0" + by auto + then have "h_seg (length l) l \ []" + using \1 < m\ \l \ WW\ len_h_seg by fastforce + with \1 < m\ show ?thesis + apply (simp add: h_def len_h_seg \l \ WW\) + by (meson \0 < length l\ bij_betw_inv_into_left bij_h_seg l) + qed (auto simp: h_def) + next + fix l + assume "l \ WW'" + then have l: "l \ W' (length l div m)" + using WW_seg_def \1 < m\ seg_W' by (fastforce simp: WW'_def) + show "?g l \ WW" + proof (cases "l=[]") + case False + then have "l \ W' 0" + using WW_seg_def seg_W' by fastforce + with l have "inv_into (WW_seg (length l div m)) (h_seg (length l div m)) l \ WW_seg (length l div m)" + by (metis Nat.neq0_conv bij_betwE bij_betw_inv_into bij_h_seg) + then show ?thesis + using False WW_seg_subset_WW by auto + qed (auto simp: WW_def) + + show "h (?g l) = l" + proof (cases "l=[]") + case False + then have "0 < length l div m" + using WW_seg_def l seg_W' by fastforce + then have "inv_into (WW_seg (length l div m)) (h_seg (length l div m)) l \ WW_seg (length l div m)" + by (metis bij_betw_imp_surj_on bij_h_seg inv_into_into l) + then show ?thesis + using bij_h_seg [of "length l div m"] WW_seg_def \0 < length l div m\ bij_betw_inv_into_right l + by (fastforce simp add: h_def) + qed (auto simp: h_def) + qed + fix a b + assume "a \ WW" "b \ WW" + show "(a, b) \ Restr (lenlex less_than) WW \ (h a, h b) \ Restr (lenlex less_than) WW'" + (is "?lhs = ?rhs") + proof + assume L: ?lhs + then consider "length a < length b" | "length a = length b" "(a, b) \ lex less_than" + by (auto simp: lenlex_conv) + then show ?rhs + proof cases + case 1 + then have "length (h a) < length (h b)" + using \1 < m\ \a \ WW\ \b \ WW\ h_def len_h_seg by auto + then have "(h a, h b) \ lenlex less_than" + by (auto simp: lenlex_conv) + then show ?thesis + using \a \ WW\ \b \ WW\ \bij_betw h WW WW'\ bij_betwE by fastforce + next + case 2 + then have ab: "a \ WW_seg (length a)" "b \ WW_seg (length a)" + using \a \ WW\ \b \ WW\ by (auto simp: WW_seg_def) + have "length (h a) = length (h b)" + using 2 \a \ WW\ \b \ WW\ h_def len_h_seg by force + moreover have "(a, b) \ lenlex less_than" + using L by blast + then have "(h_seg (length a) a, h_seg (length a) b) \ lenlex less_than" + using 2 ab h_seg_iff by blast + ultimately show ?thesis + using 2 \a \ WW\ \b \ WW\ \bij_betw h WW WW'\ bij_betwE h_def by fastforce + qed + next + assume R: ?rhs + then have R': "(h a, h b) \ lenlex less_than" + by blast + then consider "length a < length b" + | "length a = length b" "(h a, h b) \ lex less_than" + using \a \ WW\ \b \ WW\ \m > 1\ + by (auto simp: lenlex_conv h_def len_h_seg split: if_split_asm) + then show ?lhs + proof cases + case 1 + then have "(a, b) \ lenlex less_than" + using omega_sum_less_iff by auto + then show ?thesis + by (simp add: \a \ WW\ \b \ WW\) + next + case 2 + then have ab: "a \ WW_seg (length a)" "b \ WW_seg (length a)" + using \a \ WW\ \b \ WW\ by (auto simp: WW_seg_def) + then have "(a, b) \ lenlex less_than" + using bij_betwE [OF bij_h_seg] \a \ WW\ \b \ WW\ R' 2 + by (simp add: h_def h_seg_iff split: if_split_asm) + then show ?thesis + using \a \ WW\ \b \ WW\ by blast + qed + qed + qed + + let ?fh = "f \ image h" + have "bij_betw h WW WW'" + using h unfolding iso_ll_def iso_iff2 by (fastforce simp: FR_WW FR_WW') + then have fh: "?fh \ [WW]\<^bsup>2\<^esup> \ {.. WW'" "y \ WW'" "length x = length y" "x \ y" for x y + proof - + obtain p q where "x \ W' p" and "y \ W' q" + using WW'_def \x \ WW'\ \y \ WW'\ by blast + then obtain n where "{x,y} \ [W' n]\<^bsup>2\<^esup>" + using seg_W' \1 < m\ \length x = length y\ \x \ y\ + by (auto simp: WW'_def WW_seg_def subset_iff) + then show "f{x,y} = 0" + using f_W' by blast + qed + then have fh_eq_0_eqlen: "?fh{x,y} = 0" if "x \ WW" "y \ WW" "length x = length y" "x \ y" for x y + using \bij_betw h WW WW'\ that hlen + by (simp add: bij_betw_iff_bijections) metis + have m_f_0: "\x\[M]\<^bsup>2\<^esup>. f x = 0" if "M \ WW" "card M = m" for M + proof - + have "finite M" + using False m that by auto + with not1 [simplified, rule_format, of M] f + show ?thesis + using that \1 < m\ + apply (simp add: Pi_iff image_subset_iff finite_ordertype_eq_card m) + by (metis less_2_cases nsets_mono numeral_2_eq_2 subset_iff) + qed + have m_fh_0: "\x\[M]\<^bsup>2\<^esup>. ?fh x = 0" if "M \ WW" "card M = m" for M + proof - + have "h ` M \ WW" + using \WW' \ WW\ \bij_betw h WW WW'\ bij_betwE that(1) by fastforce + moreover have "card (h ` M) = m" + by (metis \bij_betw h WW WW'\ bij_betw_def bij_betw_subset card_image that) + ultimately have "\x \ [h ` M]\<^bsup>2\<^esup>. f x = 0" + by (metis m_f_0) + then obtain Y where "f (h ` Y) = 0" "finite Y" "card Y = 2" "Y \ M" + apply (simp add: nsets_def subset_image_iff) + by (metis \M \ WW\ \bij_betw h WW WW'\ bij_betw_def card_image card_infinite inj_on_subset zero_neq_numeral) + then show ?thesis + by (auto simp: nsets_def) + qed + + obtain N j where "infinite N" + and N: "\k u. \k > 0; u \ [WW]\<^bsup>2\<^esup>; Form k u; [enum N k] < inter_scheme k u; List.set (inter_scheme k u) \ N\ \ ?fh u = j k" + using lemma_3_6 [OF fh] by blast + + have infN': "infinite (enum N ` {k<..})" for k + by (simp add: \infinite N\ enum_works finite_image_iff infinite_Ioi strict_mono_imp_inj_on) + have j_0: "j k = 0" if "k>0" for k + proof - + obtain M where M: "M \ [WW]\<^bsup>m\<^esup>" + and MF: "\u. u \ [M]\<^bsup>2\<^esup> \ Form k u" + and Mi: "\u. u \ [M]\<^bsup>2\<^esup> \ List.set (inter_scheme k u) \ enum N ` {k<..}" + using lemma_3_7 [OF infN' \k > 0\] by metis + obtain u where u: "u \ [M]\<^bsup>2\<^esup>" "?fh u = 0" + using m_fh_0 [of M] M [unfolded nsets_def] by force + moreover + have \
: "Form k u" "List.set (inter_scheme k u) \ enum N ` {k<..}" + by (simp_all add: MF Mi \u \ [M]\<^bsup>2\<^esup>\) + moreover have "u \ [WW]\<^bsup>2\<^esup>" + using M u by (auto simp: nsets_def) + moreover have "enum N ` {k<..} \ N" + using \infinite N\ range_enum by auto + moreover + have "[enum N k] < inter_scheme k u" + using inter_scheme [of k u] strict_mono_enum [OF \infinite N\] \
+ apply (auto simp: less_list_def subset_image_iff subset_eq Bex_def image_iff) + by (metis hd_in_set strict_mono_def) + ultimately show ?thesis + using N that by auto + qed + obtain X where "X \ WW" and otX: "ordertype X (lenlex less_than) = \\\" + and X: "\u. u \ [X]\<^bsup>2\<^esup> \ + \l. Form l u \ (l > 0 \ [enum N l] < inter_scheme l u \ List.set (inter_scheme l u) \ N)" + using lemma_3_8 [OF \infinite N\] ot' by blast + have 0: "?fh ` [X]\<^bsup>2\<^esup> \ {0}" + proof clarsimp + fix u + assume u: "u \ [X]\<^bsup>2\<^esup>" + obtain l where "Form l u" and l: "l > 0 \ [enum N l] < inter_scheme l u \ List.set (inter_scheme l u) \ N" + using u X by blast + have "?fh u = 0" + proof (cases "l > 0") + case False + then have "l = 0" + by blast + then show ?thesis + by (metis Form_0_cases_raw \Form l u\ \X \ WW\ doubleton_in_nsets_2 fh_eq_0_eqlen subset_iff u) + next + case True + then obtain "[enum N l] < inter_scheme l u" "List.set (inter_scheme l u) \ N" "j l = 0" + using Nat.neq0_conv j_0 l by blast + with True show ?thesis + using \X \ WW\ N inter_scheme \Form l u\ doubleton_in_nsets_2 u by (auto simp: nsets_def) + qed + then show "f (h ` u) = 0" + by auto + qed + show ?P0 + proof (intro exI conjI) + show "h ` X \ WW" + using \WW' \ WW\ \X \ WW\ \bij_betw h WW WW'\ bij_betw_imp_surj_on by fastforce + show "ordertype (h ` X) (lenlex less_than) = \ \ \" + proof (subst ordertype_inc_eq) + show "(h x, h y) \ lenlex less_than" + if "x \ X" "y \ X" "(x, y) \ lenlex less_than" for x y + using that h \X \ WW\ by (auto simp: FR_WW FR_WW' iso_iff2 iso_ll_def) + qed (use otX in auto) + show "f ` [h ` X]\<^bsup>2\<^esup> \ {0}" + proof (clarsimp simp: image_subset_iff nsets_def) + fix Y + assume "Y \ h ` X" and "finite Y" and "card Y = 2" + have "inv_into WW h ` Y \ X" + using \X \ WW\ \Y \ h ` X\ \bij_betw h WW WW'\ bij_betw_inv_into_LEFT by blast + moreover have "finite (inv_into WW h ` Y)" + using \finite Y\ by blast + moreover have "card (inv_into WW h ` Y) = 2" + by (metis \X \ WW\ \Y \ h ` X\ \card Y = 2\ card_image inj_on_inv_into subset_image_iff subset_trans) + ultimately have "f (h ` inv_into WW h ` Y) = 0" + using 0 by (auto simp: image_subset_iff nsets_def) + then show "f Y = 0" + by (metis \X \ WW\ \Y \ h ` X\ image_inv_into_cancel image_mono order_trans) + qed + qed + qed + then show "\iH\WW. ordertype H ?R = [\\\, \] ! i \ f ` [H]\<^bsup>2\<^esup> \ {i}" + by (metis One_nat_def lessI nth_Cons_0 nth_Cons_Suc zero_less_Suc) + qed +qed + +text \Theorem 3.1 of Jean A. Larson, ibid.\ +theorem partition_\\: "\ \ elts \ \ partn_lst_VWF (\\\) [\\\,\] 2" + using partn_lst_imp_partn_lst_VWF_eq [OF partition_\\_aux] ordertype_WW by auto + +end diff --git a/thys/Ordinal_Partitions/Partitions.thy b/thys/Ordinal_Partitions/Partitions.thy new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/Partitions.thy @@ -0,0 +1,938 @@ +section \Ordinal Partitions\ + +text \Material from Jean A. Larson, + A short proof of a partition theorem for the ordinal $\omega^\omega$. + \emph{Annals of Mathematical Logic}, 6:129–-145, 1973. +Also from ``Partition Relations'' by A. Hajnal and J. A. Larson, +in \emph{Handbook of Set Theory}, edited by Matthew Foreman and Akihiro Kanamori +(Springer, 2010).\ + +theory Partitions + imports Library_Additions "ZFC_in_HOL.ZFC_Typeclasses" "ZFC_in_HOL.Cantor_NF" + +begin + +abbreviation tp :: "V set \ V" + where "tp A \ ordertype A VWF" + +subsection \Ordinal Partitions: Definitions\ + +definition partn_lst :: "[('a \ 'a) set, 'a set, V list, nat] \ bool" + where "partn_lst r B \ n \ \f \ nsets B n \ {..}. + \i < length \. \H. H \ B \ ordertype H r = (\!i) \ f ` (nsets H n) \ {i}" + +abbreviation partn_lst_VWF :: "V \ V list \ nat \ bool" + where "partn_lst_VWF \ \ partn_lst VWF (elts \)" + +lemma partn_lst_E: + assumes "partn_lst r B \ n" "f \ nsets B n \ {.." + obtains i H where "i < l" "H \ B" + "ordertype H r = \!i" "f ` (nsets H n) \ {i}" + using assms by (auto simp: partn_lst_def) + +lemma partn_lst_VWF_nontriv: + assumes "partn_lst_VWF \ \ n" "l = length \" "Ord \" "l > 0" + obtains i where "i < l" "\!i \ \" +proof - + have "{.. {}" + by (simp add: \l > 0\ lessThan_empty_iff) + then obtain f where "f \ nsets (elts \) n \ {.. elts \" and eq: "tp H = \!i" + using assms by (metis partn_lst_E) + then have "\!i \ \" + by (metis \H \ elts \\ \Ord \\ eq ordertype_le_Ord) + then show thesis + using \i < l\ that by auto +qed + +lemma partn_lst_triv0: + assumes "\!i = 0" "i < length \" "n \ 0" + shows "partn_lst r B \ n" + by (metis partn_lst_def assms bot_least image_empty nsets_empty_iff ordertype_empty) + +lemma partn_lst_triv1: + assumes "\!i \ 1" "i < length \" "n > 1" "B \ {}" "wf r" + shows "partn_lst r B \ n" + unfolding partn_lst_def +proof clarsimp + obtain \ where "\ \ B" "\ \ []" + using assms mem_0_Ord by fastforce + have 01: "\!i = 0 \ \!i = 1" + using assms by (fastforce simp: one_V_def) + fix f + assume f: "f \ [B]\<^bsup>n\<^esup> \ {..}" + with assms have "ordertype {\} r = 1 \ f ` [{\}]\<^bsup>n\<^esup> \ {i}" + "ordertype {} r = 0 \ f ` [{}]\<^bsup>n\<^esup> \ {i}" + by (auto simp: one_V_def ordertype_insert nsets_eq_empty) + with assms 01 show "\i. \H\B. ordertype H r = \ ! i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + using \\ \ B\ by auto +qed + +lemma partn_lst_two_swap: + assumes "partn_lst r B [x,y] n" shows "partn_lst r B [y,x] n" +proof - + { fix f :: "'a set \ nat" + assume f: "f \ [B]\<^bsup>n\<^esup> \ {..<2}" + then have f': "(\i. 1 - i) \ f \ [B]\<^bsup>n\<^esup> \ {..<2}" + by (auto simp: Pi_def) + obtain i H where "i<2" "H \ B" "ordertype H r = ([x,y]!i)" "((\i. 1 - i) \ f) ` (nsets H n) \ {i}" + by (auto intro: partn_lst_E [OF assms f']) + moreover have "f x = Suc 0" if "Suc 0 \ f x" "x\[H]\<^bsup>n\<^esup>" for x + using f that \H \ B\ nsets_mono by (fastforce simp: Pi_iff) + ultimately have "ordertype H r = [y,x] ! (1-i) \ f ` [H]\<^bsup>n\<^esup> \ {1-i}" + by (force simp: eval_nat_numeral less_Suc_eq) + then have "\i H. i<2 \ H\B \ ordertype H r = [y,x] ! i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + by (metis Suc_1 \H \ B\ diff_less_Suc) } + then show ?thesis + by (auto simp: partn_lst_def eval_nat_numeral) +qed + +lemma partn_lst_greater_resource: + assumes M: "partn_lst r B \ n" and "B \ C" + shows "partn_lst r C \ n" +proof (clarsimp simp: partn_lst_def) + fix f + assume "f \ [C]\<^bsup>n\<^esup> \ {..}" + then have "f \ [B]\<^bsup>n\<^esup> \ {..}" + by (metis \B \ C\ part_fn_def part_fn_subset) + then obtain i H where "i < length \" + and "H \ B" "ordertype H r = (\!i)" + and "f ` nsets H n \ {i}" + using M partn_lst_def by metis + then show "\i. \H\C. ordertype H r = \ ! i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + using \B \ C\ by blast +qed + + +lemma partn_lst_less: + assumes M: "partn_lst r B \ n" and eq: "length \' = length \" and "List.set \' \ ON" + and le: "\i. i < length \ \ \'!i \ \!i " + and r: "wf r" "trans r" "total_on B r" and "small B" + shows "partn_lst r B \' n" +proof (clarsimp simp: partn_lst_def) + fix f + assume "f \ [B]\<^bsup>n\<^esup> \ {..'}" + then obtain i H where "i < length \" + and "H \ B" "small H" and H: "ordertype H r = (\!i)" + and fi: "f ` nsets H n \ {i}" + using assms by (auto simp: partn_lst_def smaller_than_small) + then have bij: "bij_betw (ordermap H r) H (elts (\!i))" + using ordermap_bij [of r H] + by (smt assms(8) in_mono r(1) r(3) smaller_than_small total_on_def) + define H' where "H' = inv_into H (ordermap H r) ` (elts (\'!i))" + have "H' \ H" + using bij \i < length \\ bij_betw_imp_surj_on le + by (force simp: H'_def image_subset_iff intro: inv_into_into) + moreover have ot: "ordertype H' r = (\'!i)" + proof (subst ordertype_eq_iff) + show "Ord (\' ! i)" + using assms by (simp add: \i < length \\ subset_eq) + show "small H'" + by (simp add: H'_def) + show "\f. bij_betw f H' (elts (\' ! i)) \ (\x\H'. \y\H'. (f x < f y) = ((x, y) \ r))" + proof (intro exI conjI ballI) + show "bij_betw (ordermap H r) H' (elts (\' ! i))" + using \H' \ H\ + by (metis H'_def \i < length \\ bij bij_betw_inv_into_RIGHT bij_betw_subset le less_eq_V_def) + show "(ordermap H r x < ordermap H r y) = ((x, y) \ r)" + if "x \ H'" "y \ H'" for x y + proof (intro iffI ordermap_mono_less) + assume "ordermap H r x < ordermap H r y" + then show "(x, y) \ r" + by (metis \H \ B\ assms(8) calculation in_mono leD ordermap_mono_le r smaller_than_small that total_on_def) + qed (use assms that \H' \ H\ \small H\ in auto) + qed + show "total_on H' r" + using r by (meson \H \ B\ \H' \ H\ subsetD total_on_def) + qed (use r in auto) + ultimately show "\i'. \H\B. ordertype H r = \' ! i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + using \H \ B\ \i < length \\ fi assms + by (metis image_mono nsets_mono subset_trans) +qed + + +text \Holds because no $n$-sets exist!\ +lemma partn_lst_VWF_degenerate: + assumes "k < n" + shows "partn_lst_VWF \ (ord_of_nat k # \s) n" +proof (clarsimp simp: partn_lst_def) + fix f :: "V set \ nat" + have "[elts (ord_of_nat k)]\<^bsup>n\<^esup> = {}" + by (simp add: nsets_eq_empty assms finite_Ord_omega) + then have "f ` [elts (ord_of_nat k)]\<^bsup>n\<^esup> \ {0}" + by auto + then show "\i < Suc (length \s). \H\elts \. tp H = (ord_of_nat k # \s) ! i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + using assms ordertype_eq_Ord [of "ord_of_nat k"] elts_ord_of_nat less_Suc_eq_0_disj + by fastforce +qed + +lemma partn_lst_VWF_\_2: + assumes "Ord \" + shows "partn_lst_VWF (\ \ (1+\)) [2, \ \ (1+\)] 2" (is "partn_lst_VWF ?\ _ _") +proof (clarsimp simp: partn_lst_def) + fix f + assume f: "f \ [elts ?\]\<^bsup>2\<^esup> \ {..iH\elts ?\. tp H = [2, ?\] ! i \ f ` [H]\<^bsup>2\<^esup> \ {i}" + proof (cases "\x \ elts ?\. \y \ elts ?\. x \ y \ f{x,y} = 0") + case True + then obtain x y where "x \ elts ?\" "y \ elts ?\" "x \ y" "f {x, y} = 0" + by auto + then have "{x,y} \ elts ?\" "tp {x,y} = 2" + "f ` [{x, y}]\<^bsup>2\<^esup> \ {0}" + by auto (simp add: eval_nat_numeral ordertype_VWF_finite_nat) + with \x \ y\ show ?thesis + by (metis nth_Cons_0 zero_less_Suc) + next + case False + with f have "\x\elts ?\. \y\elts ?\. x \ y \ f {x, y} = 1" + unfolding Pi_iff using lessThan_Suc by force + then have "tp (elts ?\) = ?\" "f ` [elts ?\]\<^bsup>2\<^esup> \ {Suc 0}" + by (auto simp: assms nsets_2_eq) + then show ?thesis + by (metis lessI nth_Cons_0 nth_Cons_Suc subsetI) + qed +qed + + +subsection \Relating partition properties on @{term VWF} to the general case\ + +text \Two very similar proofs here!\ + +lemma partn_lst_imp_partn_lst_VWF_eq: + assumes part: "partn_lst r U \ n" and \: "ordertype U r = \" "small U" + and r: "wf r" "trans r" "total_on U r" + shows "partn_lst_VWF \ \ n" + unfolding partn_lst_def +proof clarsimp + fix f + assume f: "f \ [elts \]\<^bsup>n\<^esup> \ {..}" + define cv where "cv \ \X. ordermap U r ` X" + have bij: "bij_betw (ordermap U r) U (elts \)" + using ordermap_bij [of "r" U] assms by blast + then have bij_cv: "bij_betw cv ([U]\<^bsup>n\<^esup>) ([elts \]\<^bsup>n\<^esup>)" + using bij_betw_nsets cv_def by blast + then have func: "f \ cv \ [U]\<^bsup>n\<^esup> \ {..}" and "inj_on (ordermap U r) U" + using bij bij_betw_def bij_betw_apply f by fastforce+ + then have cv_part: "\\x\[X]\<^bsup>n\<^esup>. f (cv x) = i; X \ U; a \ [cv X]\<^bsup>n\<^esup>\ \ f a = i" for a X i n + by (force simp: cv_def nsets_def subset_image_iff inj_on_subset finite_image_iff card_image) + have ot_eq [simp]: "tp (cv X) = ordertype X r" if "X \ U" for X + unfolding cv_def + proof (rule ordertype_inc_eq) + fix u v + assume "u \ X" "v \ X" and "(u,v) \ r" + with that have "ordermap U r u < ordermap U r v" + by (simp add: assms ordermap_mono_less subset_eq) + then show "(ordermap U r u, ordermap U r v) \ VWF" + by (simp add: r) + next + show "total_on X r" + using that r by (auto simp: total_on_def) + show "small X" + by (meson \small U\ smaller_than_small that) + qed (use assms in auto) + obtain X i where "X \ U" and X: "ordertype X r = \!i" "(f \ cv) ` [X]\<^bsup>n\<^esup> \ {i}" + and "i < length \" + using part func by (auto simp: partn_lst_def) + show "\i < length \. \H\elts \. tp H = \!i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + proof (intro exI conjI) + show "i < length \" + by (simp add: \i < length \\) + show "cv X \ elts \" + using \X \ U\ bij bij_betw_imp_surj_on cv_def by blast + show "tp (cv X) = \ ! i" + by (simp add: X(1) \X \ U\) + show "f ` [cv X]\<^bsup>n\<^esup> \ {i}" + using X \X \ U\ cv_part unfolding image_subset_iff cv_def + by (metis comp_apply insertCI singletonD) + qed +qed + +lemma partn_lst_imp_partn_lst_VWF: + assumes part: "partn_lst r U \ n" and \: "ordertype U r \ \" "small U" + and r: "wf r" "trans r" "total_on U r" + shows "partn_lst_VWF \ \ n" + by (metis assms less_eq_V_def partn_lst_imp_partn_lst_VWF_eq partn_lst_greater_resource) + +lemma partn_lst_VWF_imp_partn_lst_eq: + assumes part: "partn_lst_VWF \ \ n" and \: "ordertype U r = \" "small U" + and r: "wf r" "trans r" "total_on U r" + shows "partn_lst r U \ n" + unfolding partn_lst_def +proof clarsimp + fix f + assume f: "f \ [U]\<^bsup>n\<^esup> \ {..}" + define cv where "cv \ \X. inv_into U (ordermap U r) ` X" + have bij: "bij_betw (ordermap U r) U (elts \)" + using ordermap_bij [of "r" U] assms by blast + then have bij_cv: "bij_betw cv ([elts \]\<^bsup>n\<^esup>) ([U]\<^bsup>n\<^esup>)" + using bij_betw_nsets bij_betw_inv_into unfolding cv_def by blast + then have func: "f \ cv \ [elts \]\<^bsup>n\<^esup> \ {..}" + using bij_betw_apply f by fastforce + have "inj_on (ordermap U r) U" + using bij bij_betw_def by blast + then have cv_part: "\\x\[X]\<^bsup>n\<^esup>. f (cv x) = i; X \ elts \; a \ [cv X]\<^bsup>n\<^esup>\ \ f a = i" for a X i n + apply ( simp add: cv_def nsets_def subset_image_iff inj_on_subset finite_image_iff card_image) + by (metis bij bij_betw_def card_image inj_on_finite inj_on_inv_into subset_eq) + have ot_eq [simp]: "ordertype (cv X) r = tp X" if "X \ elts \" for X + unfolding cv_def + proof (rule ordertype_inc_eq) + show "small X" + using down that by auto + show "(inv_into U (ordermap U r) x, inv_into U (ordermap U r) y) \ r" + if "x \ X" "y \ X" and "(x,y) \ VWF" for x y + proof - + have xy: "x \ ordermap U r ` U" "y \ ordermap U r ` U" + using \X \ elts \\ \x \ X\ \y \ X\ bij bij_betw_imp_surj_on by blast+ + then have eq: "ordermap U r (inv_into U (ordermap U r) x) = x" "ordermap U r (inv_into U (ordermap U r) y) = y" + by (meson f_inv_into_f)+ + then have "y \ elts x" + by (metis (no_types) VWF_non_refl mem_imp_VWF that(3) trans_VWF trans_def) + then show ?thesis + by (metis (no_types) VWF_non_refl xy eq assms(3) inv_into_into ordermap_mono r(1) r(3) that(3) total_on_def) + qed + qed (use r in auto) + obtain X i where "X \ elts \" and X: "tp X = \!i" "(f \ cv) ` [X]\<^bsup>n\<^esup> \ {i}" + and "i < length \" + using part func by (auto simp: partn_lst_def) + show "\i < length \. \H\U. ordertype H r = \!i \ f ` [H]\<^bsup>n\<^esup> \ {i}" + proof (intro exI conjI) + show "i < length \" + by (simp add: \i < length \\) + show "cv X \ U" + using \X \ elts \\ bij bij_betw_imp_surj_on bij_betw_inv_into cv_def by blast + show "ordertype (cv X) r = \ ! i" + by (simp add: X(1) \X \ elts \\) + show "f ` [cv X]\<^bsup>n\<^esup> \ {i}" + using X \X \ elts \\ cv_part unfolding image_subset_iff cv_def + by (metis comp_apply insertCI singletonD) + qed +qed + +corollary partn_lst_VWF_imp_partn_lst: + assumes "partn_lst_VWF \ \ n" and \: "ordertype U r \ \" "small U" + "wf r" "trans r" "total_on U r" + shows "partn_lst r U \ n" + by (metis assms less_eq_V_def partn_lst_VWF_imp_partn_lst_eq partn_lst_greater_resource) + +subsection \Simple consequences of the definitions\ + +text \A restatement of the infinite Ramsey theorem using partition notation\ +lemma Ramsey_partn: "partn_lst_VWF \ [\,\] 2" +proof (clarsimp simp: partn_lst_def) + fix f + assume "f \ [elts \]\<^bsup>2\<^esup> \ {..x\elts \. \y\elts \. x \ y \ f {x, y} < 2" + by (auto simp: nsets_def eval_nat_numeral) + obtain H i where H: "H \ elts \" and "infinite H" + and t: "i < Suc (Suc 0)" + and teq: "\x\H. \y\H. x \ y \ f {x, y} = i" + using Ramsey2 [OF infinite_\ *] by (auto simp: eval_nat_numeral) + then have "tp H = [\, \] ! i" + using less_2_cases eval_nat_numeral ordertype_infinite_\ by force + moreover have "f ` {N. N \ H \ finite N \ card N = 2} \ {i}" + by (force simp: teq card_2_iff) + ultimately have "f ` [H]\<^bsup>2\<^esup> \ {i}" + by (metis (no_types) nsets_def numeral_2_eq_2) + then show "\iH\elts \. tp H = [\,\] ! i \ f ` [H]\<^bsup>2\<^esup> \ {i}" + using H \tp H = [\, \] ! i\ t by blast +qed + +text \This is the counterexample sketched in Hajnal and Larson, section 9.1.\ +proposition omega_basic_counterexample: + assumes "Ord \" + shows "\ partn_lst_VWF \ [succ (vcard \), \] 2" +proof - + obtain \ where fun\: "\ \ elts \ \ elts (vcard \)" and inj\: "inj_on \ (elts \)" + using inj_into_vcard by auto + have Ord\: "Ord (\ x)" if "x \ elts \" for x + using Ord_in_Ord fun\ that by fastforce + define f where "f A \ @i::nat. \x y. A = {x,y} \ x < y \ (\ x < \ y \ i=0 \ \ y < \ x \ i=1)" for A + have f_Pi: "f \ [elts \]\<^bsup>2\<^esup> \ {.. [elts \]\<^bsup>2\<^esup>" + then obtain x y where xy: "x \ elts \" "y \ elts \" "x < y" and A: "A = {x,y}" + apply (clarsimp simp: nsets_2_eq) + by (metis Ord_in_Ord Ord_linear_lt assms insert_commute) + consider "\ x < \ y" | "\ y < \ x" + by (metis Ord\ Ord_linear_lt inj\ inj_onD less_imp_not_eq2 xy) + then show "f A \ {..x < y\ A exE_some [OF _ f_def]) + qed + have fiff: "\ x < \ y \ i=0 \ \ y < \ x \ i=1" + if f: "f {x,y} = i" and xy: "x \ elts \" "y \ elts \" "x x < \ y" | "\ y < \ x" + using xy by (metis Ord\ Ord_linear_lt inj\ inj_onD less_V_def) + then show ?thesis + proof cases + case 1 + then have "f{x,y} = 0" + using \x by (force simp: f_def Set.doubleton_eq_iff) + then show ?thesis + using "1" f by auto + next + case 2 + then have "f{x,y} = 1" + using \x by (force simp: f_def Set.doubleton_eq_iff) + then show ?thesis + using "2" f by auto + qed + qed + have False + if eq: "tp H = succ (vcard \)" and H: "H \ elts \" + and 0: "\A. A \ [H]\<^bsup>2\<^esup> \ f A = 0" for H + proof - + have [simp]: "small H" + using H down by auto + have OH: "Ord x" if "x \ H" for x + using H Ord_in_Ord \Ord \\ that by blast + have \: "\ x < \ y" if "x\H" "y\H" "x ` H \ elts (vcard \)" + using H fun\ by auto + have "tp H = tp (\ ` H)" + proof (rule ordertype_VWF_inc_eq [symmetric]) + show "\ ` H \ ON" + using H Ord\ by blast + qed (auto simp: \ OH subsetI) + also have "\ \ vcard \" + by (simp add: H sub_vcard assms ordertype_le_Ord) + finally show False + by (simp add: eq succ_le_iff) + qed + moreover have False + if eq: "tp H = \" and H: "H \ elts \" + and 1: "\A. A \ [H]\<^bsup>2\<^esup> \ f A = Suc 0" for H + proof - + have [simp]: "small H" + using H down by auto + define \ where "\ \ inv_into H (ordermap H VWF) \ ord_of_nat" + have bij: "bij_betw (ordermap H VWF) H (elts \)" + by (metis ordermap_bij \small H\ eq total_on_VWF wf_VWF) + then have "bij_betw (inv_into H (ordermap H VWF)) (elts \) H" + by (simp add: bij_betw_inv_into) + then have \: "bij_betw \ UNIV H" + unfolding \_def + by (metis \_def bij_betw_comp_iff2 bij_betw_def elts_of_set inf inj_ord_of_nat order_refl) + have Ord\: "Ord (\ k)" for k + by (meson H Ord_in_Ord UNIV_I \ assms bij_betw_apply subsetD) + obtain k where k: "((\ \ \)(Suc k), (\ \ \) k) \ VWF" + using wf_VWF wf_iff_no_infinite_down_chain by blast + have \: "\ y < \ x" if "x\H" "y\H" "x (Suc k) \ \ k" + proof - + have "(\ (Suc k), \ k) \ VWF \ \ (Suc k) = \ k" + using that Ord\ Ord_mem_iff_lt by auto + then have "ordermap H VWF (\ (Suc k)) \ ordermap H VWF (\ k)" + by (metis \ \small H\ bij_betw_imp_surj_on ordermap_mono_le rangeI trans_VWF wf_VWF) + moreover have "ordermap H VWF (\ (Suc k)) = succ (ord_of_nat k)" + unfolding \_def using bij bij_betw_inv_into_right by force + moreover have "ordermap H VWF (\ k) = ord_of_nat k" + apply (simp add: \_def) + by (meson bij bij_betw_inv_into_right ord_of_nat_\) + ultimately have "succ (ord_of_nat k) \ ord_of_nat k" + by simp + then show False + by (simp add: less_eq_V_def) + qed + then have "\ k < \ (Suc k)" + by (metis Ord\ Ord_linear_lt dual_order.strict_implies_order eq_refl) + then have "(\ \ \)(Suc k) < (\ \ \)k" + using \ \ bij_betw_apply by force + then show False + using k + apply (simp add: subset_iff) + by (metis H Ord\ UNIV_I VWF_iff_Ord_less \ bij_betw_imp_surj_on image_subset_iff) + qed + ultimately show ?thesis + apply (simp add: partn_lst_def image_subset_iff) + by (metis f_Pi less_2_cases nth_Cons_0 nth_Cons_Suc numeral_2_eq_2) +qed + +subsection \Specker's theorem\ + +definition form_split :: "[nat,nat,nat,nat,nat] \ bool" where + "form_split a b c d i \ a \ c \ (i=0 \ a b c + i=1 \ a c b + i=2 \ a c d + i=3 \ a=c \ b\d)" + +definition form :: "[(nat*nat)set, nat] \ bool" where + "form u i \ \a b c d. u = {(a,b),(c,d)} \ form_split a b c d i" + +definition scheme :: "[(nat*nat)set] \ nat set" where + "scheme u \ fst ` u \ snd ` u" + +definition UU :: "(nat*nat) set" + where "UU \ {(a,b). a < b}" + +lemma ordertype_UNIV_\2: "ordertype UNIV pair_less = \\2" + using ordertype_Times [of concl: UNIV UNIV less_than less_than] + by (simp add: total_less_than pair_less_def ordertype_nat_\ numeral_2_eq_2) + +lemma ordertype_UU_ge_\2: "ordertype UNIV pair_less \ ordertype UU pair_less" +proof (rule ordertype_inc_le) + define \ where "\ \ \(m,n). (m, Suc (m+n))" + show "(\ (x::nat \ nat), \ y) \ pair_less" if "(x, y) \ pair_less" for x y + using that by (auto simp: \_def pair_less_def split: prod.split) + show "range \ \ UU" + by (auto simp: \_def UU_def) +qed auto + +lemma ordertype_UU_\2: "ordertype UU pair_less = \\2" + by (metis eq_iff ordertype_UNIV_\2 ordertype_UU_ge_\2 ordertype_mono small top_greatest trans_pair_less wf_pair_less) + + +text \Lemma 2.3 of Jean A. Larson, + A short proof of a partition theorem for the ordinal $\omega^\omega$. + \emph{Annals of Mathematical Logic}, 6:129–-145, 1973.\ +lemma lemma_2_3: + fixes f :: "(nat \ nat) set \ nat" + assumes "f \ [UU]\<^bsup>2\<^esup> \ {..k u. \k < 4; u \ [UU]\<^bsup>2\<^esup>; form u k; scheme u \ N\ \ f u = js!k" +proof - + have f_less2: "f {p,q} < Suc (Suc 0)" if "p \ q" "p \ UU" "q \ UU" for p q + proof - + have "{p,q} \ [UU]\<^bsup>2\<^esup>" + using that by (simp add: nsets_def) + then show ?thesis + using assms by (simp add: Pi_iff) + qed + define f0 where "f0 \ (\A::nat set. THE x. \a b c d. A = {a,b,c,d} \ a b c x = f {(a,b),(c,d)})" + have f0: "f0 {a,b,c,d} = f {(a,b),(c,d)}" if "a [X]\<^bsup>4\<^esup>" + using that by (auto simp: nsets_def) + then obtain a b c d where "X = {a,b,c,d} \ a b cN t. infinite N \ t < Suc (Suc 0) + \ (\X. X \ N \ finite X \ card X = 4 \ f0 X = t)" + using Ramsey [of UNIV 4 f0 2] by (simp add: eval_nat_numeral) + then obtain N0 j0 where "infinite N0" and j0: "j0 < Suc (Suc 0)" and N0: "\A. A \ [N0]\<^bsup>4\<^esup> \ f0 A = j0" + by (auto simp: nsets_def) + + define f1 where "f1 \ (\A::nat set. THE x. \a b c d. A = {a,b,c,d} \ a b c x = f {(a,c),(b,d)})" + have f1: "f1 {a,b,c,d} = f {(a,c),(b,d)}" if "a [X]\<^bsup>4\<^esup>" + using that by (auto simp: nsets_def) + then obtain a b c d where "X = {a,b,c,d} \ a b cN t. N \ N0 \ infinite N \ t < Suc (Suc 0) + \ (\X. X \ N \ finite X \ card X = 4 \ f1 X = t)" + using \infinite N0\ Ramsey [of N0 4 f1 2] by (simp add: eval_nat_numeral) + then obtain N1 j1 where "N1 \ N0" "infinite N1" and j1: "j1 < Suc (Suc 0)" and N1: "\A. A \ [N1]\<^bsup>4\<^esup> \ f1 A = j1" + by (auto simp: nsets_def) + + define f2 where "f2 \ (\A::nat set. THE x. \a b c d. A = {a,b,c,d} \ a b c x = f {(a,d),(b,c)})" + have f2: "f2 {a,b,c,d} = f {(a,d),(b,c)}" if "a [X]\<^bsup>4\<^esup>" + using that by (auto simp: nsets_def) + then obtain a b c d where "X = {a,b,c,d} \ a b cN t. N \ N1 \ infinite N \ t < Suc (Suc 0) + \ (\X. X \ N \ finite X \ card X = 4 \ f2 X = t)" + using \infinite N1\ Ramsey [of N1 4 f2 2] by (simp add: eval_nat_numeral) + then obtain N2 j2 where "N2 \ N1" "infinite N2" and j2: "j2 < Suc (Suc 0)" and N2: "\A. A \ [N2]\<^bsup>4\<^esup> \ f2 A = j2" + by (auto simp: nsets_def) + + define f3 where "f3 \ (\A::nat set. THE x. \a b c. A = {a,b,c} \ a b x = f {(a,b),(a,c)})" + have f3: "f3 {a,b,c} = f {(a,b),(a,c)}" if "a [X]\<^bsup>3\<^esup>" + using that by (auto simp: nsets_def) + then obtain a b c where "X = {a,b,c} \ a bN t. N \ N2 \ infinite N \ t < Suc (Suc 0) + \ (\X. X \ N \ finite X \ card X = 3 \ f3 X = t)" + using \infinite N2\ Ramsey [of N2 3 f3 2] by (simp add: eval_nat_numeral) + then obtain N3 j3 where "N3 \ N2" "infinite N3" and j3: "j3 < Suc (Suc 0)" and N3: "\A. A \ [N3]\<^bsup>3\<^esup> \ f3 A = j3" + by (auto simp: nsets_def) + + show thesis + proof + fix k u + assume "k < 4" + and u: "form u k" "scheme u \ N3" + and UU: "u \ [UU]\<^bsup>2\<^esup>" + then consider (0) "k=0" | (1) "k=1" | (2) "k=2" | (3) "k=3" + by linarith + then show "f u = [j0,j1,j2,j3] ! k" + proof cases + case 0 + have "N3 \ N0" + using \N1 \ N0\ \N2 \ N1\ \N3 \ N2\ by auto + then show ?thesis + using u 0 + apply (auto simp: form_def form_split_def scheme_def simp flip: f0) + apply (force simp: nsets_def intro: N0) + done + next + case 1 + have "N3 \ N1" + using \N2 \ N1\ \N3 \ N2\ by auto + then show ?thesis + using u 1 + apply (auto simp: form_def form_split_def scheme_def simp flip: f1) + apply (force simp: nsets_def intro: N1) + done + next + case 2 + then show ?thesis + using u \N3 \ N2\ + apply (auto simp: form_def form_split_def scheme_def nsets_def simp flip: f2) + apply (force simp: nsets_def intro: N2) + done + next + case 3 + { fix a b d + assume "{(a, b), (a, d)} \ [UU]\<^bsup>2\<^esup>" + and *: "a \ N3" "b \ N3" "d \ N3" "b \ d" + then have "ainfinite N3\) +qed + + +text \Lemma 2.4 of Jean A. Larson, ibid.\ +lemma lemma_2_4: + assumes "infinite N" "k < 4" + obtains M where "M \ [UU]\<^bsup>m\<^esup>" "\u. u \ [M]\<^bsup>2\<^esup> \ form u k" "\u. u \ [M]\<^bsup>2\<^esup> \ scheme u \ N" +proof - + obtain f:: "nat \ nat" where "bij_betw f UNIV N" "strict_mono f" + using assms by (meson bij_enumerate enumerate_mono strict_monoI) + then have iff[simp]: "f x = f y \ x=y" "f x < f y \ x N" for x + using bij_betw_apply [OF \bij_betw f UNIV N\] by blast + define M0 where "M0 = (\i. (f(2*i), f(Suc(2*i)))) ` {..i. (f i, f(m+i))) ` {..i. (f i, f(2*m-i))) ` {..i. (f 0, f (Suc i))) ` {..i. (f (2 * i), f (Suc (2 * i)))) {.. [UU]\<^bsup>m\<^esup>" + by (simp add: M0_def nsets_def card_image UU_def image_subset_iff) + next + fix u + assume u: "(u::(nat \ nat) set) \ [M0]\<^bsup>2\<^esup>" + then obtain x y where "u = {x,y}" "x \ y" "x \ M0" "y \ M0" + by (auto simp: nsets_2_eq) + then obtain i j where "i f (2 * j)" + by (simp add: \i less_imp_le_nat) + ultimately show "form u k" + apply (simp add: 0 form_def form_split_def nsets_def) + apply (rule_tac x="f (2 * i)" in exI) + apply (rule_tac x="f (Suc (2 * i))" in exI) + apply (rule_tac x="f (2 * j)" in exI) + apply (rule_tac x="f (Suc (2 * j))" in exI) + apply auto + done + show "scheme u \ N" + using ueq by (auto simp: scheme_def) + qed + next + case 1 + show ?thesis + proof + have "inj_on (\i. (f i, f(m+i))) {.. [UU]\<^bsup>m\<^esup>" + by (simp add: M1_def nsets_def card_image UU_def image_subset_iff) + next + fix u + assume u: "(u::(nat \ nat) set) \ [M1]\<^bsup>2\<^esup>" + then obtain x y where "u = {x,y}" "x \ y" "x \ M1" "y \ M1" + by (auto simp: nsets_2_eq) + then obtain i j where "i N" + using ueq by (auto simp: scheme_def) + qed + next + case 2 + show ?thesis + proof + have "inj_on (\i. (f i, f(2*m-i))) {.. [UU]\<^bsup>m\<^esup>" + by (auto simp: M2_def nsets_def card_image UU_def image_subset_iff) + next + fix u + assume u: "(u::(nat \ nat) set) \ [M2]\<^bsup>2\<^esup>" + then obtain x y where "u = {x,y}" "x \ y" "x \ M2" "y \ M2" + by (auto simp: nsets_2_eq) + then obtain i j where "i N" + using ueq by (auto simp: scheme_def) + qed + next + case 3 + show ?thesis + proof + have "inj_on (\i. (f 0, f (Suc i))) {.. [UU]\<^bsup>m\<^esup>" + by (auto simp: M3_def nsets_def card_image UU_def image_subset_iff) + next + fix u + assume u: "(u::(nat \ nat) set) \ [M3]\<^bsup>2\<^esup>" + then obtain x y where "u = {x,y}" "x \ y" "x \ M3" "y \ M3" + by (auto simp: nsets_2_eq) + then obtain i j where "i N" + using ueq by (auto simp: scheme_def) + qed + qed +qed + + +text \Lemma 2.5 of Jean A. Larson, ibid.\ +lemma lemma_2_5: + assumes "infinite N" + obtains X where "X \ UU" "ordertype X pair_less = \\2" + "\u. u \ [X]\<^bsup>2\<^esup> \ (\k<4. form u k) \ scheme u \ N" +proof - + obtain C + where dis: "pairwise (\i j. disjnt (C i) (C j)) UNIV" + and N: "(\i. C i) \ N" and infC: "\i::nat. infinite (C i)" + using assms infinite_infinite_partition by blast + then have "\\::nat \ nat. inj \ \ range \ = C i \ strict_mono \" for i + by (metis bij_betw_imp_inj_on bij_betw_imp_surj_on bij_enumerate enumerate_mono infC strict_mono_def) + then obtain \:: "[nat,nat] \ nat" + where \: "\i. inj (\ i) \ range (\ i) = C i \ strict_mono (\ i)" + by metis + then have \_in_C [simp]: "\ i j \ C i' \ i'=i" for i i' j + using dis by (fastforce simp: pairwise_def disjnt_def) + have less_iff [simp]: "\ i j' < \ i j \ j' < j" for i j' j + by (simp add: \ strict_mono_less) + let ?a = "\ 0" + define X where "X \ {(?a i, b) | i b. ?a i < b \ b \ C (Suc i)}" + show thesis + proof + show "X \ UU" + by (auto simp: X_def UU_def) + show "ordertype X pair_less = \\2" + proof (rule antisym) + have "ordertype X pair_less \ ordertype UU pair_less" + by (simp add: \X \ UU\ ordertype_mono) + then show "ordertype X pair_less \ \\2" + using ordertype_UU_\2 by auto + define \ where "\ \ \(i,j::nat). (?a i, \ (Suc i) (?a j))" + have "\i j. i < j \ \ 0 i < \ (Suc i) (\ 0 j)" + by (meson \ le_less_trans less_iff strict_mono_imp_increasing) + then have subX: "\ ` UU \ X" + by (auto simp: UU_def \_def X_def) + then have "ordertype (\ ` UU) pair_less \ ordertype X pair_less" + by (simp add: ordertype_mono) + moreover have "ordertype (\ ` UU) pair_less = ordertype UU pair_less" + proof (rule ordertype_inc_eq) + show "(\ x, \ y) \ pair_less" + if "x \ UU" "y \ UU" and "(x, y) \ pair_less" for x y + using that by (auto simp: UU_def \_def pair_less_def) + qed auto + ultimately show "\\2 \ ordertype X pair_less" + using ordertype_UU_\2 by simp + qed + next + fix U + assume "U \ [X]\<^bsup>2\<^esup>" + then obtain a b c d where Ueq: "U = {(a,b),(c,d)}" and ne: "(a,b) \ (c,d)" and inX: "(a,b) \ X" "(c,d) \ X" and "a \ c" + apply (auto simp: nsets_def subset_iff eval_nat_numeral card_Suc_eq Set.doubleton_eq_iff) + apply (metis nat_le_linear)+ + done + show "(\k<4. form U k) \ scheme U \ N" + proof + show "scheme U \ N" + using inX N \ by (fastforce simp: scheme_def Ueq X_def) + next + consider "a < c" | "a = c \ b \ d" + using \a \ c\ ne nat_less_le by blast + then show "\k<4. form U k" + proof cases + case 1 + have *: "a < b" "b \ c" "c < d" + using inX by (auto simp: X_def) + moreover have "\a < c; c < b; \ d < b\ \ b < d" + using inX apply (clarsimp simp: X_def not_less) + by (metis \ \_in_C imageE nat.inject nat_less_le) + ultimately consider (k0) "a b c c b c da \ c\ by blast + then show ?thesis by force + next + case k1 + then have "form U 1" + unfolding form_def form_split_def using Ueq \a \ c\ by blast + then show ?thesis by force + next + case k2 + then have "form U 2" + unfolding form_def form_split_def using Ueq \a \ c\ by blast + then show ?thesis by force + qed + next + case 2 + then have "form_split a b c d 3" + by (auto simp: form_split_def) + then show ?thesis + using Ueq form_def leI by force + qed + qed + qed +qed + +text \Theorem 2.1 of Jean A. Larson, ibid.\ +lemma Specker_aux: + assumes "\ \ elts \" + shows "partn_lst pair_less UU [\\2,\] 2" + unfolding partn_lst_def +proof clarsimp + fix f + assume f: "f \ [UU]\<^bsup>2\<^esup> \ {..: "?P0 \ ?P1" + proof (rule disjCI) + assume "\ ?P1" + then have not1: "\M. \M \ UU; ordertype M pair_less = \\ \ \x\[M]\<^bsup>2\<^esup>. f x \ Suc 0" + by auto + obtain m where m: "\ = ord_of_nat m" + using assms elts_\ by auto + then have f_eq_0: "M \ [UU]\<^bsup>m\<^esup> \ \x\[M]\<^bsup>2\<^esup>. f x = 0" for M + using not1 [of M] finite_ordertype_eq_card [of M pair_less m] f + apply (clarsimp simp: nsets_def eval_nat_numeral Pi_def) + by (meson less_Suc0 not_less_less_Suc_eq subset_trans) + obtain N js where "infinite N" and N: "\k u. \k < 4; u \ [UU]\<^bsup>2\<^esup>; form u k; scheme u \ N\ \ f u = js!k" + using f lemma_2_3 by blast + obtain M0 where M0: "M0 \ [UU]\<^bsup>m\<^esup>" "\u. u \ [M0]\<^bsup>2\<^esup> \ form u 0" "\u. u \ [M0]\<^bsup>2\<^esup> \ scheme u \ N" + by (rule lemma_2_4 [OF \infinite N\]) auto + obtain M1 where M1: "M1 \ [UU]\<^bsup>m\<^esup>" "\u. u \ [M1]\<^bsup>2\<^esup> \ form u 1" "\u. u \ [M1]\<^bsup>2\<^esup> \ scheme u \ N" + by (rule lemma_2_4 [OF \infinite N\]) auto + obtain M2 where M2: "M2 \ [UU]\<^bsup>m\<^esup>" "\u. u \ [M2]\<^bsup>2\<^esup> \ form u 2" "\u. u \ [M2]\<^bsup>2\<^esup> \ scheme u \ N" + by (rule lemma_2_4 [OF \infinite N\]) auto + obtain M3 where M3: "M3 \ [UU]\<^bsup>m\<^esup>" "\u. u \ [M3]\<^bsup>2\<^esup> \ form u 3" "\u. u \ [M3]\<^bsup>2\<^esup> \ scheme u \ N" + by (rule lemma_2_4 [OF \infinite N\]) auto + have "js!0 = 0" + using N [of 0 ] M0 f_eq_0 [of M0] by (force simp: nsets_def eval_nat_numeral) + moreover have "js!1 = 0" + using N [of 1] M1 f_eq_0 [of M1] by (force simp: nsets_def eval_nat_numeral) + moreover have "js!2 = 0" + using N [of 2 ] M2 f_eq_0 [of M2] by (force simp: nsets_def eval_nat_numeral) + moreover have "js!3 = 0" + using N [of 3 ] M3 f_eq_0 [of M3] by (force simp: nsets_def eval_nat_numeral) + ultimately have js0: "js!k = 0" if "k < 4" for k + using that by (auto simp: eval_nat_numeral less_Suc_eq) + obtain X where "X \ UU" and otX: "ordertype X pair_less = \\2" + and X: "\u. u \ [X]\<^bsup>2\<^esup> \ (\k<4. form u k) \ scheme u \ N" + using \infinite N\ lemma_2_5 by auto + moreover have "f ` [X]\<^bsup>2\<^esup> \ {0}" + proof (clarsimp simp: image_subset_iff) + fix u + assume u: "u \ [X]\<^bsup>2\<^esup>" + then have u_UU2: "u \ [UU]\<^bsup>2\<^esup>" + using \X \ UU\ nsets_mono by blast + show "f u = 0" + using X u N [OF _ u_UU2] js0 by auto + qed + ultimately show "\X \ UU. ordertype X pair_less = \\2 \ f ` [X]\<^bsup>2\<^esup> \ {0}" + by blast + qed + then show "\iH\UU. ordertype H pair_less = [\\2, \] ! i \ f ` [H]\<^bsup>2\<^esup> \ {i}" + proof + show "?P0 \ ?thesis" + by (metis nth_Cons_0 numeral_2_eq_2 pos2) + show "?P1 \ ?thesis" + by (metis One_nat_def lessI nth_Cons_0 nth_Cons_Suc) + qed +qed + +theorem Specker: "\ \ elts \ \ partn_lst_VWF (\\2) [\\2,\] 2" + using partn_lst_imp_partn_lst_VWF_eq [OF Specker_aux] ordertype_UU_\2 wf_pair_less by blast + +end diff --git a/thys/Ordinal_Partitions/ROOT b/thys/Ordinal_Partitions/ROOT new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/ROOT @@ -0,0 +1,12 @@ +chapter AFP + +session Ordinal_Partitions (AFP) = HOL + + options [timeout = 600] + sessions + "HOL-Library" "ZFC_in_HOL" "Nash_Williams" + theories + Omega_Omega + document_files + "root.tex" + "root.bib" + diff --git a/thys/Ordinal_Partitions/document/root.bib b/thys/Ordinal_Partitions/document/root.bib new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/document/root.bib @@ -0,0 +1,51 @@ +%% This BibTeX bibliography file was created using BibDesk. +%% http://bibdesk.sourceforge.net/ + + +%% Created for Larry Paulson at 2020-08-03 15:23:09 +0100 + + +%% Saved with string encoding Unicode (UTF-8) + + + +@article{erdos-theorem-partition-corr, + Author = {Paul Erd{\"o}s and E. C. Milner}, + Date-Added = {2020-08-03 15:20:59 +0100}, + Date-Modified = {2020-08-03 15:23:08 +0100}, + Doi = {10.4153/CMB-1974-062-6}, + Journal = {Canadian Mathematical Bulletin}, + Month = jun, + Number = {2}, + Pages = {305}, + Title = {A Theorem in the Partition Calculus Corrigendum}, + Volume = {17}, + Year = {1974}, + Bdsk-Url-1 = {https://doi.org/10.4153/CMB-1972-088-1}} + +@article{erdos-theorem-partition, + Author = {Paul Erd{\"o}s and E. C. Milner}, + Date-Added = {2020-08-02 14:51:07 +0100}, + Date-Modified = {2020-08-02 14:53:46 +0100}, + Doi = {10.4153/CMB-1972-088-1}, + Journal = {Canadian Mathematical Bulletin}, + Month = dec, + Number = {4}, + Pages = {501-505}, + Title = {A Theorem in the Partition Calculus}, + Volume = {15}, + Year = {1972}} + +@article{larson-short-proof, + Author = {Jean A. Larson}, + Date-Added = {2020-08-02 14:49:21 +0100}, + Date-Modified = {2020-08-02 14:49:21 +0100}, + Doi = {10.1016/0003-4843(73)90006-5}, + Journal = {Annals of Mathematical Logic}, + Month = dec, + Number = {2}, + Pages = {129-145}, + Title = {A Short Proof of a Partition Theorem for the Ordinal $\omega^\omega$}, + Volume = {6}, + Year = {1973}, + Bdsk-Url-1 = {https://doi.org/10.1016/0003-4843(73)90006-5}} diff --git a/thys/Ordinal_Partitions/document/root.tex b/thys/Ordinal_Partitions/document/root.tex new file mode 100644 --- /dev/null +++ b/thys/Ordinal_Partitions/document/root.tex @@ -0,0 +1,40 @@ +\documentclass[11pt,a4paper]{article} +\usepackage{isabelle,isabellesym} +\usepackage{amssymb} +\usepackage{stmaryrd} + +% this should be the last package used +\usepackage{pdfsetup} + +% urls in roman style, theory text in math-similar italics +\urlstyle{rm} +\isabellestyle{it} + +\begin{document} + +\title{A Partition Theorem for the Ordinal $\omega^\omega$} +\author{Lawrence C. Paulson} +\maketitle + +\begin{abstract} +The theory of partition relations concerns generalisations of Ramsey's theorem. +For any ordinal $\alpha$, write $\alpha \to (\alpha, m)^2$ if for each function~$f$ from unordered pairs of elements of~$\alpha$ into $\{0,1\}$, either there is a subset $X\subseteq \alpha$ order-isomorphic to $\alpha$ such that $f\{x,y\}=0$ for all $\{x,y\}\subseteq X$, or there is an $m$ element set $Y\subseteq \alpha$ such that $f\{x,y\}=1$ for all $\{x,y\}\subseteq Y$. (In both cases, with $\{x,y\}$ we require $x\not=y$.) +In particular, the infinite Ramsey theorem can be written in this notation as $\omega \to (\omega, \omega)^2$, or if we restrict~$m$ to the positive integers as above, then $\omega \to (\omega, m)^2$ for all~$m$ \cite{larson-short-proof}. + +This entry formalises Larson's proof of $\omega^\omega \to (\omega^\omega, m)^2$ along with a similar proof of a result due to Specker: $\omega^2 \to (\omega^2, m)^2$. Also proved is a necessary result by Erd{\H o}s and Milner~\cite{erdos-theorem-partition,erdos-theorem-partition-corr}: $\omega^{1+\alpha\cdot n} \to (\omega^{1+\alpha}, 2^n)^2$. + +These examples demonstrate the use of Isabelle/HOL to formalise advanced results that combine ZF set theory with basic concepts like lists and natural numbers. +\end{abstract} + +\tableofcontents + +% include generated text of all theories +\input{session} + +\section{Acknowledgements} +The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the European Research Council. Many thanks to Mirna D\v{z}amonja (who suggested the project) and Angeliki Koutsoukou-Argyraki for assistance at tricky moments. + +\bibliographystyle{abbrv} +\bibliography{root} + +\end{document} diff --git a/thys/ROOTS b/thys/ROOTS --- a/thys/ROOTS +++ b/thys/ROOTS @@ -1,548 +1,553 @@ ADS_Functor AODV -Attack_Trees -Auto2_HOL -Auto2_Imperative_HOL AVL-Trees AWN Abortable_Linearizable_Modules Abs_Int_ITP2012 Abstract-Hoare-Logics Abstract-Rewriting Abstract_Completeness Abstract_Soundness Adaptive_State_Counting Affine_Arithmetic Aggregation_Algebras Akra_Bazzi Algebraic_Numbers Algebraic_VCs Allen_Calculus +Amicable_Numbers Amortized_Complexity AnselmGod Applicative_Lifting Approximation_Algorithms Architectural_Design_Patterns Aristotles_Assertoric_Syllogistic Arith_Prog_Rel_Primes ArrowImpossibilityGS +Attack_Trees +Auto2_HOL +Auto2_Imperative_HOL AutoFocus-Stream Automated_Stateful_Protocol_Verification Automatic_Refinement AxiomaticCategoryTheory BDD +BNF_CC BNF_Operations Banach_Steinhaus Bell_Numbers_Spivey Berlekamp_Zassenhaus Bernoulli Bertrands_Postulate Bicategory BinarySearchTree Binding_Syntax_Theory Binomial-Heaps Binomial-Queues -BNF_CC Bondy Boolean_Expression_Checkers Bounded_Deducibility_Security Buchi_Complementation Budan_Fourier Buffons_Needle Buildings BytecodeLogicJmlTypes C2KA_DistributedSystems CAVA_Automata CAVA_LTL_Modelchecker CCS CISC-Kernel CRDT CYK CakeML CakeML_Codegen Call_Arity Card_Equiv_Relations Card_Multisets Card_Number_Partitions Card_Partitions Cartan_FP Case_Labeling Catalan_Numbers Category Category2 Category3 Cauchy Cayley_Hamilton Certification_Monads +Chandy_Lamport Chord_Segments Circus Clean ClockSynchInst Closest_Pair_Points CofGroups Coinductive Coinductive_Languages Collections Comparison_Sort_Lower_Bound Compiling-Exceptions-Correctly +Complete_Non_Orders Completeness -Complete_Non_Orders Complex_Geometry Complx ComponentDependencies ConcurrentGC ConcurrentIMP Concurrent_Ref_Alg Concurrent_Revisions Consensus_Refined Constructive_Cryptography Constructor_Funs Containers CoreC++ Core_DOM Count_Complex_Roots CryptHOL CryptoBasedCompositionalProperties DFS_Framework DPT-SAT-Solver DataRefinementIBP Datatype_Order_Generator Decl_Sem_Fun_PL Decreasing-Diagrams Decreasing-Diagrams-II Deep_Learning Density_Compiler Dependent_SIFUM_Refinement Dependent_SIFUM_Type_Systems Depth-First-Search Derangements Deriving Descartes_Sign_Rule Dict_Construction Differential_Dynamic_Logic Differential_Game_Logic Dijkstra_Shortest_Path Diophantine_Eqns_Lin_Hom Dirichlet_L Dirichlet_Series +DiscretePricing Discrete_Summation -DiscretePricing DiskPaxos DynamicArchitectures Dynamic_Tables E_Transcendental Echelon_Form EdmondsKarp_Maxflow Efficient-Mergesort Elliptic_Curves_Group_Law Encodability_Process_Calculi Epistemic_Logic Ergodic_Theory Error_Function Euler_MacLaurin Euler_Partition Example-Submission -Factored_Transition_System_Bounding -Farkas FFT FLP FOL-Fitting FOL_Harrison FOL_Seq_Calc1 +Factored_Transition_System_Bounding Falling_Factorial_Sum +Farkas FeatherweightJava Featherweight_OCL Fermat3_4 FileRefinement FinFun Finger-Trees Finite_Automata_HF First_Order_Terms First_Welfare_Theorem Fishburn_Impossibility Fisher_Yates Flow_Networks Floyd_Warshall Flyspeck-Tame FocusStreamsCaseStudies Forcing Formal_SSA Formula_Derivatives Fourier Free-Boolean-Algebra Free-Groups FunWithFunctions FunWithTilings Functional-Automata Functional_Ordered_Resolution_Prover Furstenberg_Topology GPU_Kernel_PL Gabow_SCC Game_Based_Crypto Gauss-Jordan-Elim-Fun Gauss_Jordan Gauss_Sums Gaussian_Integers GenClock General-Triangle Generalized_Counting_Sort Generic_Deriving Generic_Join GewirthPGCProof Girth_Chromatic GoedelGod Goodstein_Lambda GraphMarkingIBP Graph_Saturation Graph_Theory Green Groebner_Bases Groebner_Macaulay Gromov_Hyperbolicity Group-Ring-Module HOL-CSP HOLCF-Prelude HRB-Slicing Heard_Of Hello_World HereditarilyFinite Hermite Hidden_Markov_Models Higher_Order_Terms Hoare_Time HotelKeyCards Huffman Hybrid_Logic Hybrid_Multi_Lane_Spatial_Logic Hybrid_Systems_VCs HyperCTL IEEE_Floating_Point IMAP-CRDT IMO2019 IMP2 IMP2_Binary_Heap IP_Addresses Imperative_Insertion_Sort Impossible_Geometry Incompleteness Incredible_Proof_Machine Inductive_Confidentiality InfPathElimination InformationFlowSlicing InformationFlowSlicing_Inter Integration Interval_Arithmetic_Word32 Iptables_Semantics Irrational_Series_Erdos_Straus Irrationality_J_Hancl Isabelle_C Isabelle_Meta_Model Jacobson_Basic_Algebra Jinja JinjaThreads JiveDataStoreModel Jordan_Hoelder Jordan_Normal_Form KAD KAT_and_DRA KBPs KD_Tree Key_Agreement_Strong_Adversaries Kleene_Algebra Knuth_Bendix_Order Knot_Theory Knuth_Bendix_Order Knuth_Morris_Pratt Koenigsberg_Friendship Kruskal Kuratowski_Closure_Complement LLL_Basis_Reduction LLL_Factorization LOFT LTL +LTL_Master_Theorem +LTL_Normal_Form LTL_to_DRA LTL_to_GBA -LTL_Master_Theorem -LTL_Normal_Form Lam-ml-Normalization LambdaAuth LambdaMu +Lambda_Free_EPO Lambda_Free_KBOs Lambda_Free_RPOs Lambert_W Landau_Symbols Laplace_Transform Latin_Square LatticeProperties -Lambda_Free_EPO Launchbury Lazy-Lists-II Lazy_Case Lehmer Lifting_Definition_Option LightweightJava LinearQuantifierElim Linear_Inequalities Linear_Programming Linear_Recurrences Liouville_Numbers List-Index List-Infinite List_Interleaving List_Inversions List_Update LocalLexing Localization_Ring Locally-Nameless-Sigma Lowe_Ontological_Argument Lower_Semicontinuous Lp Lucas_Theorem MFMC_Countable +MFODL_Monitor_Optimized +MFOTL_Monitor MSO_Regex_Equivalence Markov_Models Marriage Mason_Stothers Matrices_for_ODEs Matrix Matrix_Tensor Matroids Max-Card-Matching Median_Of_Medians_Selection Menger Mersenne_Primes -MFODL_Monitor_Optimized -MFOTL_Monitor MiniML Minimal_SSA Minkowskis_Theorem Minsky_Machines Modal_Logics_for_NTS Modular_Assembly_Kit_Security Monad_Memo_DP Monad_Normalisation MonoBoolTranAlgebra MonoidalCategory Monomorphic_Monad MuchAdoAboutTwo +Multi_Party_Computation Multirelations -Multi_Party_Computation Myhill-Nerode Name_Carrying_Type_Inference Nash_Williams Nat-Interval-Logic Native_Word Nested_Multisets_Ordinals Network_Security_Policy_Verification Neumann_Morgenstern_Utility No_FTL_observers Nominal2 Noninterference_CSP Noninterference_Concurrent_Composition Noninterference_Generic_Unwinding Noninterference_Inductive_Unwinding Noninterference_Ipurge_Unwinding Noninterference_Sequential_Composition NormByEval Nullstellensatz Octonions +OpSets Open_Induction -OpSets Optics Optimal_BST Orbit_Stabiliser Order_Lattice_Props Ordered_Resolution_Prover Ordinal +Ordinal_Partitions Ordinals_and_Cardinals Ordinary_Differential_Equations PCF PLM -Pell POPLmark-deBruijn PSemigroupsConvolution Pairing_Heap Paraconsistency Parity_Game Partial_Function_MR Partial_Order_Reduction Password_Authentication_Protocol +Pell Perfect-Number-Thm Perron_Frobenius Pi_Calculus Pi_Transcendental Planarity_Certificates +Poincare_Bendixson +Poincare_Disc Polynomial_Factorization Polynomial_Interpolation Polynomials -Poincare_Bendixson -Poincare_Disc Pop_Refinement Posix-Lexing Possibilistic_Noninterference Power_Sum_Polynomials Pratt_Certificate Presburger-Automata Prim_Dijkstra_Simple Prime_Distribution_Elementary Prime_Harmonic_Series Prime_Number_Theorem Priority_Queue_Braun Priority_Search_Trees Probabilistic_Noninterference Probabilistic_Prime_Tests Probabilistic_System_Zoo Probabilistic_Timed_Automata Probabilistic_While +Program-Conflict-Analysis Projective_Geometry -Program-Conflict-Analysis Promela Proof_Strategy_Language PropResPI Propositional_Proof_Systems Prpu_Maxflow PseudoHoops Psi_Calculi Ptolemys_Theorem QHLProver QR_Decomposition Quantales Quaternions Quick_Sort_Cost RIPEMD-160-SPARK ROBDD RSAPSS Ramsey-Infinite Random_BSTs +Random_Graph_Subgraph_Threshold Randomised_BSTs -Random_Graph_Subgraph_Threshold Randomised_Social_Choice Rank_Nullity_Theorem Real_Impl Recursion-Addition Recursion-Theory-I Refine_Imperative_HOL Refine_Monadic RefinementReactive Regex_Equivalence Regular-Sets Regular_Algebras Relation_Algebra Relational-Incorrectness-Logic +Relational_Disjoint_Set_Forests +Relational_Paths Rep_Fin_Groups Residuated_Lattices Resolution_FOL Rewriting_Z Ribbon_Proofs Robbins-Conjecture Root_Balanced_Tree Routing Roy_Floyd_Warshall SATSolverVerification SDS_Impossibility SIFPL SIFUM_Type_Systems SPARCv8 Safe_Distance Safe_OCL Saturation_Framework Saturation_Framework_Extensions Secondary_Sylow Security_Protocol_Refinement Selection_Heap_Sort SenSocialChoice Separata Separation_Algebra Separation_Logic_Imperative_HOL SequentInvertibility Shivers-CFA ShortestPath Show Sigma_Commit_Crypto Signature_Groebner Simpl Simple_Firewall Simplex Skew_Heap Skip_Lists Slicing Sliding_Window_Algorithm Smith_Normal_Form Smooth_Manifolds Sort_Encodings Source_Coding_Theorem Special_Function_Bounds Splay_Tree Sqrt_Babylonian Stable_Matching Statecharts Stateful_Protocol_Composition_and_Typing Stellar_Quorums Stern_Brocot Stewart_Apollonius Stirling_Formula Stochastic_Matrices Stone_Algebras Stone_Kleene_Relation_Algebras Stone_Relation_Algebras Store_Buffer_Reduction Stream-Fusion Stream_Fusion_Code Strong_Security Sturm_Sequences Sturm_Tarski Stuttering_Equivalence Subresultants Subset_Boolean_Algebras SumSquares SuperCalc Surprise_Paradox Symmetric_Polynomials Szpilrajn TESL_Language TLA Tail_Recursive_Functions Tarskis_Geometry Taylor_Models Timed_Automata Topology TortoiseHare Transcendence_Series_Hancl_Rucki Transformer_Semantics Transition_Systems_and_Automata Transitive-Closure Transitive-Closure-II Treaps Tree-Automata Tree_Decomposition Triangle Trie Twelvefold_Way Tycon Types_Tableaus_and_Goedels_God -Universal_Turing_Machine UPF UPF_Firewall +UTP +Universal_Turing_Machine UpDown_Scheme -UTP Valuation VectorSpace VeriComp Verified-Prover VerifyThis2018 VerifyThis2019 Vickrey_Clarke_Groves VolpanoSmith WHATandWHERE_Security +WOOT_Strong_Eventual_Consistency WebAssembly Weight_Balanced_Trees Well_Quasi_Orders Winding_Number_Eval -WOOT_Strong_Eventual_Consistency Word_Lib WorkerWrapper XML -Zeta_Function +ZFC_in_HOL Zeta_3_Irrational -ZFC_in_HOL +Zeta_Function pGCL diff --git a/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy b/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy new file mode 100644 --- /dev/null +++ b/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy @@ -0,0 +1,1746 @@ +(* Title: Disjoint-Set Forests + Author: Walter Guttmann + Maintainer: Walter Guttmann +*) + +theory Disjoint_Set_Forests + +imports + Aggregation_Algebras.Hoare_Logic + Stone_Kleene_Relation_Algebras.Kleene_Relation_Algebras +begin + +no_notation + trancl ("(_\<^sup>+)" [1000] 999) + +context stone_relation_algebra +begin + +text \ +We start with a few basic properties of arcs, points and rectangles. + +An arc in a Stone relation algebra corresponds to an atom in a relation algebra and represents a single edge in a graph. +A point represents a set of nodes. +A rectangle represents the Cartesian product of two sets of nodes \cite{BerghammerStruth2010}. +\ + +lemma points_arc: + "point x \ point y \ arc (x * y\<^sup>T)" + by (metis comp_associative conv_dist_comp conv_involutive equivalence_top_closed) + +lemma point_arc: + "point x \ arc (x * x\<^sup>T)" + by (simp add: points_arc) + +lemma injective_codomain: + assumes "injective x" + shows "x * (x \ 1) = x \ 1" +proof (rule antisym) + show "x * (x \ 1) \ x \ 1" + by (metis assms comp_right_one dual_order.trans inf.boundedI inf.cobounded1 inf.sup_monoid.add_commute mult_right_isotone one_inf_conv) +next + show "x \ 1 \ x * (x \ 1)" + by (metis coreflexive_idempotent inf.cobounded1 inf.cobounded2 mult_left_isotone) +qed + +abbreviation rectangle :: "'a \ bool" + where "rectangle x \ x * top * x = x" + +lemma arc_rectangle: + "arc x \ rectangle x" + using arc_top_arc by blast + +section \Relation-Algebraic Semantics of Associative Array Access\ + +text \ +The following two operations model updating array $x$ at index $y$ to value $z$, +and reading the content of array $x$ at index $y$, respectively. +The read operation uses double brackets to avoid ambiguity with list syntax. +The remainder of this section shows basic properties of these operations. +\ + +abbreviation rel_update :: "'a \ 'a \ 'a \ 'a" ("(_[_\_])" [70, 65, 65] 61) + where "x[y\z] \ (y \ z\<^sup>T) \ (-y \ x)" + +abbreviation rel_access :: "'a \ 'a \ 'a" ("(2_[[_]])" [70, 65] 65) + where "x[[y]] \ x\<^sup>T * y" + +text \Theorem 1.1\ + +lemma update_univalent: + assumes "univalent x" + and "vector y" + and "injective z" + shows "univalent (x[y\z])" +proof - + have 1: "univalent (y \ z\<^sup>T)" + using assms(3) inf_commute univalent_inf_closed by force + have "(y \ z\<^sup>T)\<^sup>T * (-y \ x) = (y\<^sup>T \ z) * (-y \ x)" + by (simp add: conv_dist_inf) + also have "... = z * (y \ -y \ x)" + by (metis assms(2) covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute) + finally have 2: "(y \ z\<^sup>T)\<^sup>T * (-y \ x) = bot" + by simp + have 3: "vector (-y)" + using assms(2) vector_complement_closed by simp + have "(-y \ x)\<^sup>T * (y \ z\<^sup>T) = (-y\<^sup>T \ x\<^sup>T) * (y \ z\<^sup>T)" + by (simp add: conv_complement conv_dist_inf) + also have "... = x\<^sup>T * (-y \ y \ z\<^sup>T)" + using 3 by (metis (mono_tags, hide_lams) conv_complement covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute) + finally have 4: "(-y \ x)\<^sup>T * (y \ z\<^sup>T) = bot" + by simp + have 5: "univalent (-y \ x)" + using assms(1) inf_commute univalent_inf_closed by fastforce + have "(x[y\z])\<^sup>T * (x[y\z]) = (y \ z\<^sup>T)\<^sup>T * (x[y\z]) \ (-y \ x)\<^sup>T * (x[y\z])" + by (simp add: conv_dist_sup mult_right_dist_sup) + also have "... = (y \ z\<^sup>T)\<^sup>T * (y \ z\<^sup>T) \ (y \ z\<^sup>T)\<^sup>T * (-y \ x) \ (-y \ x)\<^sup>T * (y \ z\<^sup>T) \ (-y \ x)\<^sup>T * (-y \ x)" + by (simp add: mult_left_dist_sup sup_assoc) + finally show ?thesis + using 1 2 4 5 by simp +qed + +text \Theorem 1.2\ + +lemma update_total: + assumes "total x" + and "vector y" + and "regular y" + and "surjective z" + shows "total (x[y\z])" +proof - + have "(x[y\z]) * top = x*top[y\top*z]" + by (simp add: assms(2) semiring.distrib_right vector_complement_closed vector_inf_comp conv_dist_comp) + also have "... = top[y\top]" + using assms(1) assms(4) by simp + also have "... = top" + using assms(3) regular_complement_top by auto + finally show ?thesis + by simp +qed + +text \Theorem 1.3\ + +lemma update_mapping: + assumes "mapping x" + and "vector y" + and "regular y" + and "bijective z" + shows "mapping (x[y\z])" + using assms update_univalent update_total by simp + +text \Theorem 1.4\ + +lemma read_injective: + assumes "injective y" + and "univalent x" + shows "injective (x[[y]])" + using assms injective_mult_closed univalent_conv_injective by blast + +text \Theorem 1.5\ + +lemma read_surjective: + assumes "surjective y" + and "total x" + shows "surjective (x[[y]])" + using assms surjective_mult_closed total_conv_surjective by blast + +text \Theorem 1.6\ + +lemma read_bijective: + assumes "bijective y" + and "mapping x" + shows "bijective (x[[y]])" + by (simp add: assms read_injective read_surjective) + +text \Theorem 1.7\ + +lemma read_point: + assumes "point p" + and "mapping x" + shows "point (x[[p]])" + using assms comp_associative read_injective read_surjective by auto + +text \Theorem 1.8\ + +lemma update_postcondition: + assumes "point x" "point y" + shows "x \ p = x * y\<^sup>T \ p[[x]] = y" + apply (rule iffI) + subgoal by (metis assms comp_associative conv_dist_comp conv_involutive covector_inf_comp_3 equivalence_top_closed vector_covector) + subgoal + apply (rule antisym) + subgoal by (metis assms conv_dist_comp conv_involutive inf.boundedI inf.cobounded1 vector_covector vector_restrict_comp_conv) + subgoal by (smt assms comp_associative conv_dist_comp conv_involutive covector_restrict_comp_conv dense_conv_closed equivalence_top_closed inf.boundedI shunt_mapping vector_covector preorder_idempotent) + done + done + +text \Back and von Wright's array independence requirements \cite{BackWright1998}, + later also lens laws \cite{FosterGreenwaldMoorePierceSchmitt2007}\ + +lemma put_get: + assumes "vector y" "surjective y" "vector z" + shows "(x[y\z])[[y]] = z" +proof - + have "(x[y\z])[[y]] = (y\<^sup>T \ z) * y \ (-y\<^sup>T \ x\<^sup>T) * y" + by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup) + also have "... = z * y" + proof - + have "(-y\<^sup>T \ x\<^sup>T) * y = bot" + by (metis assms(1) covector_inf_comp_3 inf_commute conv_complement mult_right_zero p_inf vector_complement_closed) + thus ?thesis + by (simp add: assms covector_inf_comp_3 inf_commute) + qed + also have "... = z" + by (metis assms(2,3) mult_assoc) + finally show ?thesis + . +qed + +lemma put_put: + "(x[y\z])[y\w] = x[y\w]" + by (metis inf_absorb2 inf_commute inf_le1 inf_sup_distrib1 maddux_3_13 sup_inf_absorb) + +lemma get_put: + assumes "point y" + shows "x[y\x[[y]]] = x" +proof - + have "x[y\x[[y]]] = (y \ y\<^sup>T * x) \ (-y \ x)" + by (simp add: conv_dist_comp) + also have "... = (y \ x) \ (-y \ x)" + proof - + have "y \ y\<^sup>T * x = y \ x" + proof (rule antisym) + have "y \ y\<^sup>T * x = (y \ y\<^sup>T) * x" + by (simp add: assms vector_inf_comp) + also have "(y \ y\<^sup>T) * x = y * y\<^sup>T * x" + by (simp add: assms vector_covector) + also have "... \ x" + using assms comp_isotone by fastforce + finally show "y \ y\<^sup>T * x \ y \ x" + by simp + have "y \ x \ y\<^sup>T * x" + by (simp add: assms vector_restrict_comp_conv) + thus "y \ x \ y \ y\<^sup>T * x" + by simp + qed + thus ?thesis + by simp + qed + also have "... = x" + proof - + have "regular y" + using assms bijective_regular by blast + thus ?thesis + by (metis inf.sup_monoid.add_commute maddux_3_11_pp) + qed + finally show ?thesis + . +qed + +end + +section \Relation-Algebraic Semantics of Disjoint-Set Forests\ + +text \ +A disjoint-set forest represents a partition of a set into equivalence classes. +We take the represented equivalence relation as the semantics of a forest. +It is obtained by operation \fc\ below. +Additionally, operation \wcc\ giving the weakly connected components of a graph will be used for the semantics of the union of two disjoint sets. +Finally, operation \root\ yields the root of a component tree, that is, the representative of a set containing a given element. +This section defines these operations and derives their properties. +\ + +context stone_kleene_relation_algebra +begin + +lemma equivalence_star_closed: + "equivalence x \ equivalence (x\<^sup>\)" + by (simp add: conv_star_commute star.circ_reflexive star.circ_transitive_equal) + +lemma equivalence_plus_closed: + "equivalence x \ equivalence (x\<^sup>+)" + by (simp add: conv_star_commute star.circ_reflexive star.circ_sup_one_left_unfold star.circ_transitive_equal) + +lemma reachable_without_loops: + "x\<^sup>\ = (x \ -1)\<^sup>\" +proof (rule antisym) + have "x * (x \ -1)\<^sup>\ = (x \ 1) * (x \ -1)\<^sup>\ \ (x \ -1) * (x \ -1)\<^sup>\" + by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed) + also have "... \ (x \ -1)\<^sup>\" + by (metis inf.cobounded2 le_supI mult_left_isotone star.circ_circ_mult star.left_plus_below_circ star_involutive star_one) + finally show "x\<^sup>\ \ (x \ -1)\<^sup>\" + by (metis inf.cobounded2 maddux_3_11_pp regular_one_closed star.circ_circ_mult star.circ_sup_2 star_involutive star_sub_one) +next + show "(x \ -1)\<^sup>\ \ x\<^sup>\" + by (simp add: star_isotone) +qed + +lemma star_plus_loops: + "x\<^sup>\ \ 1 = x\<^sup>+ \ 1" + using star.circ_plus_one star_left_unfold_equal sup_commute by auto + +lemma star_plus_without_loops: + "x\<^sup>\ \ -1 = x\<^sup>+ \ -1" + by (metis maddux_3_13 star_left_unfold_equal) + +text \Theorem 4.2\ + +lemma omit_redundant_points: + assumes "point p" + shows "p \ x\<^sup>\ = (p \ 1) \ (p \ x) * (-p \ x)\<^sup>\" +proof (rule antisym) + let ?p = "p \ 1" + have "?p * x * (-p \ x)\<^sup>\ * ?p \ ?p * top * ?p" + by (metis comp_associative mult_left_isotone mult_right_isotone top.extremum) + also have "... \ ?p" + by (simp add: assms injective_codomain vector_inf_one_comp) + finally have "?p * x * (-p \ x)\<^sup>\ * ?p * x \ ?p * x" + using mult_left_isotone by blast + hence "?p * x * (-p \ x)\<^sup>\ * (p \ x) \ ?p * x" + by (simp add: assms comp_associative vector_inf_one_comp) + also have 1: "... \ ?p * x * (-p \ x)\<^sup>\" + using mult_right_isotone star.circ_reflexive by fastforce + finally have "?p * x * (-p \ x)\<^sup>\ * (p \ x) \ ?p * x * (-p \ x)\<^sup>\ * (-p \ x) \ ?p * x * (-p \ x)\<^sup>\" + by (simp add: mult_right_isotone star.circ_plus_same star.left_plus_below_circ mult_assoc) + hence "?p * x * (-p \ x)\<^sup>\ * ((p \ -p) \ x) \ ?p * x * (-p \ x)\<^sup>\" + by (simp add: comp_inf.mult_right_dist_sup mult_left_dist_sup) + hence "?p * x * (-p \ x)\<^sup>\ * x \ ?p * x * (-p \ x)\<^sup>\" + by (metis assms bijective_regular inf.absorb2 inf.cobounded1 inf.sup_monoid.add_commute shunting_p) + hence "?p * x * (-p \ x)\<^sup>\ * x \ ?p * x \ ?p * x * (-p \ x)\<^sup>\" + using 1 by simp + hence "?p * (1 \ x * (-p \ x)\<^sup>\) * x \ ?p * x * (-p \ x)\<^sup>\" + by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup) + also have "... \ ?p * (1 \ x * (-p \ x)\<^sup>\)" + by (simp add: comp_associative mult_right_isotone) + finally have "?p * x\<^sup>\ \ ?p * (1 \ x * (-p \ x)\<^sup>\)" + using star_right_induct by (meson dual_order.trans le_supI mult_left_sub_dist_sup_left mult_sub_right_one) + also have "... = ?p \ ?p * x * (-p \ x)\<^sup>\" + by (simp add: comp_associative semiring.distrib_left) + finally show "p \ x\<^sup>\ \ ?p \ (p \ x) * (-p \ x)\<^sup>\" + by (simp add: assms vector_inf_one_comp) + show "?p \ (p \ x) * (-p \ x)\<^sup>\ \ p \ x\<^sup>\" + by (metis assms comp_isotone inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute le_supI star.circ_increasing star.circ_transitive_equal star_isotone star_left_unfold_equal sup.cobounded1 vector_export_comp) +qed + +text \Weakly connected components\ + +abbreviation "wcc x \ (x \ x\<^sup>T)\<^sup>\" + +text \Theorem 5.1\ + +lemma wcc_equivalence: + "equivalence (wcc x)" + apply (intro conjI) + subgoal by (simp add: star.circ_reflexive) + subgoal by (simp add: star.circ_transitive_equal) + subgoal by (simp add: conv_dist_sup conv_star_commute sup_commute) + done + +text \Theorem 5.2\ + +lemma wcc_increasing: + "x \ wcc x" + by (simp add: star.circ_sub_dist_1) + +lemma wcc_isotone: + "x \ y \ wcc x \ wcc y" + using conv_isotone star_isotone sup_mono by blast + +lemma wcc_idempotent: + "wcc (wcc x) = wcc x" + using star_involutive wcc_equivalence by auto + +text \Theorem 5.3\ + +lemma wcc_below_wcc: + "x \ wcc y \ wcc x \ wcc y" + using wcc_idempotent wcc_isotone by fastforce + +text \Theorem 5.4\ + +lemma wcc_bot: + "wcc bot = 1" + by (simp add: star.circ_zero) + +lemma wcc_one: + "wcc 1 = 1" + by (simp add: star_one) + +text \Theorem 5.5\ + +lemma wcc_top: + "wcc top = top" + by (simp add: star.circ_top) + +text \Theorem 5.6\ + +lemma wcc_with_loops: + "wcc x = wcc (x \ 1)" + by (metis conv_dist_sup star_decompose_1 star_sup_one sup_commute symmetric_one_closed) + +lemma wcc_without_loops: + "wcc x = wcc (x \ -1)" + by (metis conv_star_commute star_sum reachable_without_loops) + +lemma forest_components_wcc: + "injective x \ wcc x = forest_components x" + by (simp add: cancel_separate_1) + +text \Components of a forest, which is represented using edges directed towards the roots\ + +abbreviation "fc x \ x\<^sup>\ * x\<^sup>T\<^sup>\" + +text \Theorem 2.1\ + +lemma fc_equivalence: + "univalent x \ equivalence (fc x)" + apply (intro conjI) + subgoal by (simp add: reflexive_mult_closed star.circ_reflexive) + subgoal by (metis cancel_separate_1 eq_iff star.circ_transitive_equal) + subgoal by (simp add: conv_dist_comp conv_star_commute) + done + +text \Theorem 2.2\ + +lemma fc_increasing: + "x \ fc x" + by (metis le_supE mult_left_isotone star.circ_back_loop_fixpoint star.circ_increasing) + +text \Theorem 2.3\ + +lemma fc_isotone: + "x \ y \ fc x \ fc y" + by (simp add: comp_isotone conv_isotone star_isotone) + +text \Theorem 2.4\ + +lemma fc_idempotent: + "univalent x \ fc (fc x) = fc x" + by (metis fc_equivalence cancel_separate_1 star.circ_transitive_equal star_involutive) + +text \Theorem 2.5\ + +lemma fc_star: + "univalent x \ (fc x)\<^sup>\ = fc x" + using fc_equivalence fc_idempotent star.circ_transitive_equal by simp + +lemma fc_plus: + "univalent x \ (fc x)\<^sup>+ = fc x" + by (metis fc_star star.circ_decompose_9) + +text \Theorem 2.6\ + +lemma fc_bot: + "fc bot = 1" + by (simp add: star.circ_zero) + +lemma fc_one: + "fc 1 = 1" + by (simp add: star_one) + +text \Theorem 2.7\ + +lemma fc_top: + "fc top = top" + by (simp add: star.circ_top) + +text \Theorem 5.7\ + +lemma fc_wcc: + "univalent x \ wcc x = fc x" + by (simp add: fc_star star_decompose_1) + +text \Theorem 4.1\ + +lemma update_acyclic_1: + assumes "acyclic (p \ -1)" + and "point y" + and "point w" + and "y \ p\<^sup>T\<^sup>\ * w" + shows "acyclic ((p[w\y]) \ -1)" +proof - + let ?p = "p[w\y]" + have "w \ p\<^sup>\ * y" + using assms(2-4) by (metis (no_types, lifting) bijective_reverse conv_star_commute) + hence "w * y\<^sup>T \ p\<^sup>\" + using assms(2) shunt_bijective by blast + hence "w * y\<^sup>T \ (p \ -1)\<^sup>\" + using reachable_without_loops by auto + hence "w * y\<^sup>T \ -1 \ (p \ -1)\<^sup>\ \ -1" + by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute) + also have "... \ (p \ -1)\<^sup>+" + by (simp add: star_plus_without_loops) + finally have 1: "w \ y\<^sup>T \ -1 \ (p \ -1)\<^sup>+" + using assms(2,3) vector_covector by auto + have "?p \ -1 = (w \ y\<^sup>T \ -1) \ (-w \ p \ -1)" + by (simp add: inf_sup_distrib2) + also have "... \ (p \ -1)\<^sup>+ \ (-w \ p \ -1)" + using 1 sup_left_isotone by blast + also have "... \ (p \ -1)\<^sup>+ \ (p \ -1)" + using comp_inf.mult_semi_associative sup_right_isotone by auto + also have "... = (p \ -1)\<^sup>+" + by (metis star.circ_back_loop_fixpoint sup.right_idem) + finally have "(?p \ -1)\<^sup>+ \ (p \ -1)\<^sup>+" + by (metis comp_associative comp_isotone star.circ_transitive_equal star.left_plus_circ star_isotone) + also have "... \ -1" + using assms(1) by blast + finally show ?thesis + by simp +qed + +lemma rectangle_star_rectangle: + "rectangle a \ a * x\<^sup>\ * a \ a" + by (metis mult_left_isotone mult_right_isotone top.extremum) + +lemma arc_star_arc: + "arc a \ a * x\<^sup>\ * a \ a" + using arc_top_arc rectangle_star_rectangle by blast + +lemma star_rectangle_decompose: + assumes "rectangle a" + shows "(a \ x)\<^sup>\ = x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\" +proof (rule antisym) + have 1: "1 \ x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\" + by (simp add: star.circ_reflexive sup.coboundedI1) + have "(a \ x) * (x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\) = a * x\<^sup>\ \ a * x\<^sup>\ * a * x\<^sup>\ \ x\<^sup>+ \ x\<^sup>+ * a * x\<^sup>\" + by (metis comp_associative semiring.combine_common_factor semiring.distrib_left sup_commute) + also have "... = a * x\<^sup>\ \ x\<^sup>+ \ x\<^sup>+ * a * x\<^sup>\" + using assms rectangle_star_rectangle by (simp add: mult_left_isotone sup_absorb1) + also have "... = x\<^sup>+ \ x\<^sup>\ * a * x\<^sup>\" + by (metis comp_associative star.circ_loop_fixpoint sup_assoc sup_commute) + also have "... \ x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\" + using star.left_plus_below_circ sup_left_isotone by auto + finally show "(a \ x)\<^sup>\ \ x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\" + using 1 by (metis comp_right_one le_supI star_left_induct) +next + show "x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\ \ (a \ x)\<^sup>\" + by (metis comp_isotone le_supE le_supI star.circ_increasing star.circ_transitive_equal star_isotone sup_ge2) +qed + +lemma star_arc_decompose: + "arc a \ (a \ x)\<^sup>\ = x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\" + using arc_top_arc star_rectangle_decompose by blast + +lemma plus_rectangle_decompose: + assumes "rectangle a" + shows "(a \ x)\<^sup>+ = x\<^sup>+ \ x\<^sup>\ * a * x\<^sup>\" +proof - + have "(a \ x)\<^sup>+ = (a \ x) * (x\<^sup>\ \ x\<^sup>\ * a * x\<^sup>\)" + by (simp add: assms star_rectangle_decompose) + also have "... = a * x\<^sup>\ \ a * x\<^sup>\ * a * x\<^sup>\ \ x\<^sup>+ \ x\<^sup>+ * a * x\<^sup>\" + by (metis comp_associative semiring.combine_common_factor semiring.distrib_left sup_commute) + also have "... = a * x\<^sup>\ \ x\<^sup>+ \ x\<^sup>+ * a * x\<^sup>\" + using assms rectangle_star_rectangle by (simp add: mult_left_isotone sup_absorb1) + also have "... = x\<^sup>+ \ x\<^sup>\ * a * x\<^sup>\" + by (metis comp_associative star.circ_loop_fixpoint sup_assoc sup_commute) + finally show ?thesis + by simp +qed + +text \Theorem 6.1\ + +lemma plus_arc_decompose: + "arc a \ (a \ x)\<^sup>+ = x\<^sup>+ \ x\<^sup>\ * a * x\<^sup>\" + using arc_top_arc plus_rectangle_decompose by blast + +text \Theorem 6.2\ + +lemma update_acyclic_2: + assumes "acyclic (p \ -1)" + and "point y" + and "point w" + and "y \ p\<^sup>\ * w = bot" + shows "acyclic ((p[w\y]) \ -1)" +proof - + let ?p = "p[w\y]" + have "y\<^sup>T * p\<^sup>\ * w \ -1" + using assms(4) comp_associative pseudo_complement schroeder_3_p by auto + hence 1: "p\<^sup>\ * w * y\<^sup>T * p\<^sup>\ \ -1" + by (metis comp_associative comp_commute_below_diversity star.circ_transitive_equal) + have "?p \ -1 \ (w \ y\<^sup>T) \ (p \ -1)" + by (metis comp_inf.mult_right_dist_sup dual_order.trans inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc le_supI sup.cobounded1 sup_ge2) + also have "... = w * y\<^sup>T \ (p \ -1)" + using assms(2,3) by (simp add: vector_covector) + finally have "(?p \ -1)\<^sup>+ \ (w * y\<^sup>T \ (p \ -1))\<^sup>+" + by (simp add: comp_isotone star_isotone) + also have "... = (p \ -1)\<^sup>+ \ (p \ -1)\<^sup>\ * w * y\<^sup>T * (p \ -1)\<^sup>\" + using assms(2,3) plus_arc_decompose points_arc by (simp add: comp_associative) + also have "... \ (p \ -1)\<^sup>+ \ p\<^sup>\ * w * y\<^sup>T * p\<^sup>\" + using reachable_without_loops by auto + also have "... \ -1" + using 1 assms(1) by simp + finally show ?thesis + by simp +qed + +lemma acyclic_down_closed: + "x \ y \ acyclic y \ acyclic x" + using comp_isotone star_isotone by fastforce + +text \Theorem 6.3\ + +lemma update_acyclic_3: + assumes "acyclic (p \ -1)" + and "point w" + shows "acyclic ((p[w\w]) \ -1)" +proof - + let ?p = "p[w\w]" + have "?p \ -1 \ (w \ w\<^sup>T \ -1) \ (p \ -1)" + by (metis comp_inf.mult_right_dist_sup inf.cobounded2 inf.sup_monoid.add_assoc sup_right_isotone) + also have "... = p \ -1" + using assms(2) by (metis comp_inf.covector_complement_closed equivalence_top_closed inf_top.right_neutral maddux_3_13 pseudo_complement regular_closed_top regular_one_closed vector_covector vector_top_closed) + finally show ?thesis + using assms(1) acyclic_down_closed by blast +qed + +text \Root of the tree containing point $x$ in the disjoint-set forest $p$\ + +abbreviation "root p x \ p\<^sup>T\<^sup>\ * x \ (p \ 1) * top" + +text \Theorem 3.1\ + +lemma root_var: + "root p x = (p \ 1) * p\<^sup>T\<^sup>\ * x" + by (simp add: coreflexive_comp_top_inf inf_commute mult_assoc) + +text \Theorem 3.2\ + +lemma root_successor_loop: + "univalent p \ root p x = p[[root p x]]" + by (metis root_var injective_codomain comp_associative conv_dist_inf coreflexive_symmetric equivalence_one_closed inf.cobounded2 univalent_conv_injective) + +lemma root_transitive_successor_loop: + "univalent p \ root p x = p\<^sup>T\<^sup>\ * (root p x)" + by (metis mult_1_right star_one star_simulation_right_equal root_successor_loop) + +end + +context stone_relation_algebra_tarski +begin + +text \Two basic results about points using the Tarski rule of relation algebras\ + +lemma point_in_vector_partition: + assumes "point x" + and "vector y" + shows "x \ -y \ x \ --y" +proof (cases "x * x\<^sup>T \ -y") + case True + have "x \ x * x\<^sup>T * x" + by (simp add: ex231c) + also have "... \ -y * x" + by (simp add: True mult_left_isotone) + also have "... \ -y" + by (metis assms(2) mult_right_isotone top.extremum vector_complement_closed) + finally show ?thesis + by simp +next + case False + have "x \ x * x\<^sup>T * x" + by (simp add: ex231c) + also have "... \ --y * x" + using False assms(1) arc_in_partition mult_left_isotone point_arc by blast + also have "... \ --y" + by (metis assms(2) mult_right_isotone top.extremum vector_complement_closed) + finally show ?thesis + by simp +qed + +lemma point_atomic_vector: + assumes "point x" + and "vector y" + and "regular y" + and "y \ x" + shows "y = x \ y = bot" +proof (cases "x \ -y") + case True + thus ?thesis + using assms(4) inf.absorb2 pseudo_complement by force +next + case False + thus ?thesis + using assms point_in_vector_partition by fastforce +qed + +text \Theorem 4.3\ + +lemma distinct_points: + assumes "point x" + and "point y" + and "x \ y" + shows "x \ y = bot" + by (metis assms antisym comp_bijective_complement inf.sup_monoid.add_commute mult_left_one pseudo_complement regular_one_closed point_in_vector_partition) + +text \Back and von Wright's array independence requirements \cite{BackWright1998}\ + +lemma put_get_different: + assumes "point y" "point w" "w \ y" + shows "(x[y\z])[[w]] = x[[w]]" +proof - + have "(x[y\z])[[w]] = (y\<^sup>T \ z) * w \ (-y\<^sup>T \ x\<^sup>T) * w" + by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup) + also have "... = z * (w \ y) \ x\<^sup>T * (w \ -y)" + by (metis assms(1) conv_complement covector_inf_comp_3 inf_commute vector_complement_closed) + also have "... = x\<^sup>T * w" + proof - + have 1: "w \ y = bot" + using assms distinct_points by simp + hence "w \ -y" + using pseudo_complement by simp + thus ?thesis + using 1 by (simp add: inf.absorb1) + qed + finally show ?thesis + . +qed + +lemma put_put_different: + assumes "point y" "point v" "v \ y" + shows "(x[y\z])[v\w] = (x[v\w])[y\z]" +proof - + have "(x[y\z])[v\w] = (v \ w\<^sup>T) \ (-v \ y \ z\<^sup>T) \ (-v \ -y \ x)" + by (simp add: comp_inf.semiring.distrib_left inf_assoc sup_assoc) + also have "... = (v \ w\<^sup>T) \ (y \ z\<^sup>T) \ (-v \ -y \ x)" + using assms distinct_points pseudo_complement inf.absorb2 by simp + also have "... = (y \ z\<^sup>T) \ (v \ w\<^sup>T) \ (-y \ -v \ x)" + by (simp add: inf_commute sup_commute) + also have "... = (y \ z\<^sup>T) \ (-y \ v \ w\<^sup>T) \ (-y \ -v \ x)" + using assms distinct_points pseudo_complement inf.absorb2 by simp + also have "... = (x[v\w])[y\z]" + by (simp add: comp_inf.semiring.distrib_left inf_assoc sup_assoc) + finally show ?thesis + . +qed + +end + +section \Verifying Operations on Disjoint-Set Forests\ + +text \ +In this section we verify the make-set, find-set and union-sets operations of disjoint-set forests. +We start by introducing syntax for updating arrays in programs. +Updating the value at a given array index means updating the whole array. +\ + +syntax + "_rel_update" :: "idt \ 'a \ 'a \ 'b com" ("(2_[_] :=/ _)" [70, 65, 65] 61) + +translations + "x[y] := z" => "(x := (y \ z\<^sup>T) \ (CONST uminus y \ x))" + +text \ +The finiteness requirement in the following class is used for proving that the operations terminate. +\ + +class finite_regular_p_algebra = p_algebra + + assumes finite_regular: "finite { x . regular x }" + +class stone_kleene_relation_algebra_tarski = stone_kleene_relation_algebra + stone_relation_algebra_tarski + +class stone_kleene_relation_algebra_tarski_finite_regular = stone_kleene_relation_algebra_tarski + finite_regular_p_algebra +begin + +subsection \Make-Set\ + +text \ +We prove two correctness results about make-set. +The first shows that the forest changes only to the extent of making one node the root of a tree. +The second result adds that only singleton sets are created. +\ + +definition "make_set_postcondition p x p0 \ x \ p = x * x\<^sup>T \ -x \ p = -x \ p0" + +theorem make_set: + "VARS p + [ point x \ p0 = p ] + p[x] := x + [ make_set_postcondition p x p0 ]" + apply vcg_tc_simp + by (simp add: make_set_postcondition_def inf_sup_distrib1 inf_assoc[THEN sym] vector_covector[THEN sym]) + +theorem make_set_2: + "VARS p + [ point x \ p0 = p \ p \ 1 ] + p[x] := x + [ make_set_postcondition p x p0 \ p \ 1 ]" +proof vcg_tc + fix p + assume 1: "point x \ p0 = p \ p \ 1" + show "make_set_postcondition (p[x\x]) x p0 \ p[x\x] \ 1" + proof (rule conjI) + show "make_set_postcondition (p[x\x]) x p0" + using 1 by (simp add: make_set_postcondition_def inf_sup_distrib1 inf_assoc[THEN sym] vector_covector[THEN sym]) + show "p[x\x] \ 1" + using 1 by (metis coreflexive_sup_closed dual_order.trans inf.cobounded2 vector_covector) + qed +qed + +text \ +The above total-correctness proof allows us to extract a function, which can be used in other implementations below. +This is a technique of \cite{Guttmann2018c}. +\ + +lemma make_set_exists: + "point x \ \p' . make_set_postcondition p' x p" + using tc_extract_function make_set by blast + +definition "make_set p x \ (SOME p' . make_set_postcondition p' x p)" + +lemma make_set_function: + assumes "point x" + and "p' = make_set p x" + shows "make_set_postcondition p' x p" +proof - + let ?P = "\p' . make_set_postcondition p' x p" + have "?P (SOME z . ?P z)" + using assms(1) make_set_exists by (meson someI) + thus ?thesis + using assms(2) make_set_def by auto +qed + +subsection \Find-Set\ + +text \ +Disjoint-set forests are represented by their parent mapping. +It is a forest except each root of a component tree points to itself. + +We prove that find-set returns the root of the component tree of the given node. +\ + +abbreviation "disjoint_set_forest p \ mapping p \ acyclic (p \ -1)" + +definition "find_set_precondition p x \ disjoint_set_forest p \ point x" +definition "find_set_invariant p x y \ find_set_precondition p x \ point y \ y \ p\<^sup>T\<^sup>\ * x" +definition "find_set_postcondition p x y \ point y \ y = root p x" + +lemma find_set_1: + "find_set_precondition p x \ find_set_invariant p x x" + apply (unfold find_set_invariant_def) + using mult_left_isotone star.circ_reflexive find_set_precondition_def by fastforce + +lemma find_set_2: + "find_set_invariant p x y \ y \ p[[y]] \ card { z . regular z \ z \ p\<^sup>T\<^sup>\ * y } = n \ find_set_invariant p x (p[[y]]) \ card { z . regular z \ z \ p\<^sup>T\<^sup>\ * (p[[y]]) } < n" +proof - + let ?s = "{ z . regular z \ z \ p\<^sup>T\<^sup>\ * y }" + let ?t = "{ z . regular z \ z \ p\<^sup>T\<^sup>\ * (p[[y]]) }" + assume 1: "find_set_invariant p x y \ y \ p[[y]] \ card ?s = n" + hence 2: "point (p[[y]])" + using read_point find_set_invariant_def find_set_precondition_def by simp + show "find_set_invariant p x (p[[y]]) \ card ?t < n" + proof (unfold find_set_invariant_def, intro conjI) + show "find_set_precondition p x" + using 1 find_set_invariant_def by simp + show "vector (p[[y]])" + using 2 by simp + show "injective (p[[y]])" + using 2 by simp + show "surjective (p[[y]])" + using 2 by simp + show "p[[y]] \ p\<^sup>T\<^sup>\ * x" + using 1 by (metis (hide_lams) find_set_invariant_def comp_associative comp_isotone star.circ_increasing star.circ_transitive_equal) + show "card ?t < n" + proof - + have 3: "(p\<^sup>T \ -1) * (p\<^sup>T \ -1)\<^sup>+ * y \ (p\<^sup>T \ -1)\<^sup>+ * y" + by (simp add: mult_left_isotone mult_right_isotone star.left_plus_below_circ) + have "p[[y]] = (p\<^sup>T \ 1) * y \ (p\<^sup>T \ -1) * y" + by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed) + also have "... \ ((p[[y]]) \ y) \ (p\<^sup>T \ -1) * y" + by (metis comp_left_subdist_inf mult_1_left semiring.add_right_mono) + also have "... = (p\<^sup>T \ -1) * y" + using 1 2 find_set_invariant_def distinct_points by auto + finally have 4: "(p\<^sup>T \ -1)\<^sup>\ * (p[[y]]) \ (p\<^sup>T \ -1)\<^sup>+ * y" + using 3 by (metis inf.antisym_conv inf.eq_refl inf_le1 mult_left_isotone star_plus mult_assoc) + hence "p\<^sup>T\<^sup>\ * (p[[y]]) \ p\<^sup>T\<^sup>\ * y" + by (metis mult_isotone order_refl star.left_plus_below_circ star_plus mult_assoc) + hence 5: "?t \ ?s" + using order_trans by auto + have 6: "y \ ?s" + using 1 find_set_invariant_def bijective_regular mult_left_isotone star.circ_reflexive by fastforce + have 7: "\ y \ ?t" + proof + assume "y \ ?t" + hence "y \ (p\<^sup>T \ -1)\<^sup>+ * y" + using 4 by (metis reachable_without_loops mem_Collect_eq order_trans) + hence "y * y\<^sup>T \ (p\<^sup>T \ -1)\<^sup>+" + using 1 find_set_invariant_def shunt_bijective by simp + also have "... \ -1" + using 1 by (metis (mono_tags, lifting) find_set_invariant_def find_set_precondition_def conv_dist_comp conv_dist_inf conv_isotone conv_star_commute equivalence_one_closed star.circ_plus_same symmetric_complement_closed) + finally have "y \ -y" + using schroeder_4_p by auto + thus False + using 1 by (metis find_set_invariant_def comp_inf.coreflexive_idempotent conv_complement covector_vector_comp inf.absorb1 inf.sup_monoid.add_commute pseudo_complement surjective_conv_total top.extremum vector_top_closed regular_closed_top) + qed + have "card ?t < card ?s" + apply (rule psubset_card_mono) + subgoal using finite_regular by simp + subgoal using 5 6 7 by auto + done + thus ?thesis + using 1 by simp + qed + qed +qed + +lemma find_set_3: + "find_set_invariant p x y \ y = p[[y]] \ find_set_postcondition p x y" +proof - + assume 1: "find_set_invariant p x y \ y = p[[y]]" + show "find_set_postcondition p x y" + proof (unfold find_set_postcondition_def, rule conjI) + show "point y" + using 1 find_set_invariant_def by simp + show "y = root p x" + proof (rule antisym) + have "y * y\<^sup>T \ p" + using 1 by (metis find_set_invariant_def find_set_precondition_def shunt_bijective shunt_mapping top_right_mult_increasing) + hence "y * y\<^sup>T \ p \ 1" + using 1 find_set_invariant_def le_infI by blast + hence "y \ (p \ 1) * top" + using 1 by (metis find_set_invariant_def order_lesseq_imp shunt_bijective top_right_mult_increasing mult_assoc) + thus "y \ root p x" + using 1 find_set_invariant_def by simp + next + have 2: "x \ p\<^sup>\ * y" + using 1 find_set_invariant_def find_set_precondition_def bijective_reverse conv_star_commute by auto + have "p\<^sup>T * p\<^sup>\ * y = p\<^sup>T * p * p\<^sup>\ * y \ (p[[y]])" + by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint) + also have "... \ p\<^sup>\ * y \ y" + using 1 by (metis find_set_invariant_def find_set_precondition_def comp_isotone mult_left_sub_dist_sup semiring.add_right_mono star.circ_back_loop_fixpoint star.circ_circ_mult star.circ_top star.circ_transitive_equal star_involutive star_one) + also have "... = p\<^sup>\ * y" + by (metis star.circ_loop_fixpoint sup.left_idem sup_commute) + finally have 3: "p\<^sup>T\<^sup>\ * x \ p\<^sup>\ * y" + using 2 by (simp add: comp_associative star_left_induct) + have "p * y \ (p \ 1) * top = (p \ 1) * p * y" + using comp_associative coreflexive_comp_top_inf inf_commute by auto + also have "... \ p\<^sup>T * p * y" + by (metis inf.cobounded2 inf.sup_monoid.add_commute mult_left_isotone one_inf_conv) + also have "... \ y" + using 1 find_set_invariant_def find_set_precondition_def mult_left_isotone by fastforce + finally have 4: "p * y \ y \ -((p \ 1) * top)" + using 1 by (metis find_set_invariant_def shunting_p bijective_regular) + have "p\<^sup>T * (p \ 1) \ p\<^sup>T \ 1" + using 1 by (metis find_set_invariant_def find_set_precondition_def N_top comp_isotone coreflexive_idempotent inf.cobounded2 inf.sup_monoid.add_commute inf_assoc one_inf_conv shunt_mapping) + hence "p\<^sup>T * (p \ 1) * top \ (p \ 1) * top" + using inf_commute mult_isotone one_inf_conv by auto + hence "p * -((p \ 1) * top) \ -((p \ 1) * top)" + by (metis comp_associative inf.sup_monoid.add_commute p_antitone p_antitone_iff schroeder_3_p) + hence "p * y \ p * -((p \ 1) * top) \ y \ -((p \ 1) * top)" + using 4 dual_order.trans le_supI sup_ge2 by blast + hence "p * (y \ -((p \ 1) * top)) \ y \ -((p \ 1) * top)" + by (simp add: mult_left_dist_sup) + hence "p\<^sup>\ * y \ y \ -((p \ 1) * top)" + by (simp add: star_left_induct) + hence "p\<^sup>T\<^sup>\ * x \ y \ -((p \ 1) * top)" + using 3 dual_order.trans by blast + thus "root p x \ y" + using 1 by (metis find_set_invariant_def shunting_p bijective_regular) + qed + qed +qed + +theorem find_set: + "VARS y + [ find_set_precondition p x ] + y := x; + WHILE y \ p[[y]] + INV { find_set_invariant p x y } + VAR { card { z . regular z \ z \ p\<^sup>T\<^sup>\ * y } } + DO y := p[[y]] + OD + [ find_set_postcondition p x y ]" + apply vcg_tc_simp + apply (fact find_set_1) + apply (rule find_set_2, force) + by (fact find_set_3) + +lemma find_set_exists: + "find_set_precondition p x \ \y . find_set_postcondition p x y" + using tc_extract_function find_set by blast + +text \ +The root of a component tree is a point, that is, represents a singleton set of nodes. +This could be proved from the definitions using Kleene-relation algebraic calculations. +But they can be avoided because the property directly follows from the postcondition of the previous correctness proof. +The corresponding algorithm shows how to obtain the root. +We therefore have an essentially constructive proof of the following result. +\ + +text \Theorem 3.3\ + +lemma root_point: + "disjoint_set_forest p \ point x \ point (root p x)" + using find_set_exists find_set_precondition_def find_set_postcondition_def by simp + +definition "find_set p x \ (SOME y . find_set_postcondition p x y)" + +lemma find_set_function: + assumes "find_set_precondition p x" + and "y = find_set p x" + shows "find_set_postcondition p x y" + by (metis assms find_set_def find_set_exists someI) + +subsection \Path Compression\ + +text \ +The path-compression technique is frequently implemented in recursive implementations of find-set +modifying the tree on the way out from recursive calls. Here we implement it using a second while-loop, +which iterates over the same path to the root and changes edges to point to the root of the component, +which is known after the while-loop in find-set completes. We prove that path compression preserves +the equivalence-relational semantics of the disjoint-set forest and also preserves the roots of the +component trees. +\ + +definition "path_compression_precondition p x y \ disjoint_set_forest p \ point x \ point y \ y = root p x" +definition "path_compression_invariant p x y p0 w \ + path_compression_precondition p x y \ point w \ y \ p\<^sup>T\<^sup>\ * w \ + (w \ x \ p[[x]] = y \ y \ x \ p\<^sup>T\<^sup>+ * w \ -x) \ p \ 1 = p0 \ 1 \ fc p = fc p0" +definition "path_compression_postcondition p x y p0 \ + path_compression_precondition p x y \ p \ 1 = p0 \ 1 \ fc p = fc p0" + +lemma path_compression_1: + "path_compression_precondition p x y \ p0 = p \ path_compression_invariant p x y p x" + using path_compression_invariant_def path_compression_precondition_def by auto + +lemma path_compression_2: + "path_compression_invariant p x y p0 w \ y \ p[[w]] \ card { z . regular z \ z \ p\<^sup>T\<^sup>\ * w } = n + \ path_compression_invariant (p[w\y]) x y p0 (p[[w]]) \ card { z . regular z \ z \ (p[w\y])\<^sup>T\<^sup>\ * (p[[w]]) } < n" +proof - + let ?p = "p[w\y]" + let ?s = "{ z . regular z \ z \ p\<^sup>T\<^sup>\ * w }" + let ?t = "{ z . regular z \ z \ ?p\<^sup>T\<^sup>\ * (p[[w]]) }" + assume 1: "path_compression_invariant p x y p0 w \ y \ p[[w]] \ card ?s = n" + hence 2: "point (p[[w]])" + by (simp add: path_compression_invariant_def path_compression_precondition_def read_point) + show "path_compression_invariant ?p x y p0 (p[[w]]) \ card ?t < n" + proof (unfold path_compression_invariant_def, intro conjI) + have 3: "mapping ?p" + using 1 by (meson path_compression_invariant_def path_compression_precondition_def update_mapping bijective_regular) + have 4: "w \ y" + using 1 by (metis (no_types, hide_lams) path_compression_invariant_def path_compression_precondition_def root_successor_loop) + hence 5: "w \ y = bot" + using 1 distinct_points path_compression_invariant_def path_compression_precondition_def by auto + hence "y * w\<^sup>T \ -1" + using pseudo_complement schroeder_4_p by auto + hence "y * w\<^sup>T \ p\<^sup>T\<^sup>\ \ -1" + using 1 shunt_bijective path_compression_invariant_def by auto + also have "... \ p\<^sup>T\<^sup>+" + by (simp add: star_plus_without_loops) + finally have 6: "y \ p\<^sup>T\<^sup>+ * w" + using 1 shunt_bijective path_compression_invariant_def by blast + have 7: "w * w\<^sup>T \ -p\<^sup>T\<^sup>+" + proof (rule ccontr) + assume "\ w * w\<^sup>T \ -p\<^sup>T\<^sup>+" + hence "w * w\<^sup>T \ --p\<^sup>T\<^sup>+" + using 1 path_compression_invariant_def point_arc arc_in_partition by blast + hence "w * w\<^sup>T \ p\<^sup>T\<^sup>+ \ 1" + using 1 path_compression_invariant_def path_compression_precondition_def mapping_regular regular_conv_closed regular_closed_star regular_mult_closed by simp + also have "... = ((p\<^sup>T \ 1) * p\<^sup>T\<^sup>\ \ 1) \ ((p\<^sup>T \ -1) * p\<^sup>T\<^sup>\ \ 1)" + by (metis comp_inf.mult_right_dist_sup maddux_3_11_pp mult_right_dist_sup regular_one_closed) + also have "... = ((p\<^sup>T \ 1) * p\<^sup>T\<^sup>\ \ 1) \ ((p \ -1)\<^sup>+ \ 1)\<^sup>T" + by (metis conv_complement conv_dist_inf conv_plus_commute equivalence_one_closed reachable_without_loops) + also have "... \ ((p\<^sup>T \ 1) * p\<^sup>T\<^sup>\ \ 1) \ (-1 \ 1)\<^sup>T" + using 1 by (metis (no_types, hide_lams) path_compression_invariant_def path_compression_precondition_def sup_right_isotone inf.sup_left_isotone conv_isotone) + also have "... = (p\<^sup>T \ 1) * p\<^sup>T\<^sup>\ \ 1" + by simp + also have "... \ (p\<^sup>T \ 1) * top \ 1" + by (metis comp_inf.comp_isotone coreflexive_comp_top_inf equivalence_one_closed inf.cobounded1 inf.cobounded2) + also have "... \ p\<^sup>T" + by (simp add: coreflexive_comp_top_inf_one) + finally have "w * w\<^sup>T \ p\<^sup>T" + by simp + hence "w \ p[[w]]" + using 1 path_compression_invariant_def shunt_bijective by blast + hence "w = p[[w]]" + using 1 2 path_compression_invariant_def epm_3 by fastforce + hence "w = p\<^sup>T\<^sup>+ * w" + using 2 by (metis comp_associative star.circ_top star_simulation_right_equal) + thus False + using 1 4 6 epm_3 path_compression_invariant_def path_compression_precondition_def by fastforce + qed + hence 8: "w \ p\<^sup>T\<^sup>+ * w = bot" + using p_antitone_iff pseudo_complement schroeder_4_p by blast + show "y \ ?p\<^sup>T\<^sup>\ * (p[[w]])" + proof - + have "(w \ y\<^sup>T)\<^sup>T * (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w \ w\<^sup>T * (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: conv_isotone mult_left_isotone) + also have "... \ w\<^sup>T * p\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: conv_isotone mult_left_isotone star_isotone mult_right_isotone) + also have "... = w\<^sup>T * p\<^sup>T\<^sup>+ * w" + by (simp add: star_plus mult_assoc) + also have "... = bot" + using 1 8 by (metis (no_types, hide_lams) path_compression_invariant_def covector_inf_comp_3 mult_assoc conv_dist_comp conv_star_commute covector_bot_closed equivalence_top_closed inf.le_iff_sup mult_left_isotone) + finally have "((w \ y\<^sup>T)\<^sup>T \ (-w \ p)\<^sup>T) * (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w \ (-w \ p)\<^sup>T * (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: bot_unique mult_right_dist_sup) + also have "... \ (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: mult_left_isotone star.left_plus_below_circ) + finally have "?p\<^sup>T * (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w \ (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: conv_dist_sup) + hence "?p\<^sup>T\<^sup>\ * p\<^sup>T * w \ (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (metis comp_associative star.circ_loop_fixpoint star_left_induct sup_commute sup_least sup_left_divisibility) + hence "w \ ?p\<^sup>T\<^sup>\ * p\<^sup>T * w \ w \ (-w \ p)\<^sup>T\<^sup>\ * p\<^sup>T * w" + using inf.sup_right_isotone by blast + also have "... \ w \ p\<^sup>T\<^sup>\ * p\<^sup>T * w" + using conv_isotone mult_left_isotone star_isotone inf.sup_right_isotone by simp + also have "... = bot" + using 8 by (simp add: star_plus) + finally have 9: "w\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w = bot" + using 1 by (metis (no_types, hide_lams) path_compression_invariant_def covector_inf_comp_3 mult_assoc conv_dist_comp covector_bot_closed equivalence_top_closed inf.le_iff_sup mult_left_isotone bot_least inf.absorb1) + have "p\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w = ((w \ p)\<^sup>T \ (-w \ p)\<^sup>T) * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w" + using 1 by (metis (no_types, lifting) bijective_regular conv_dist_sup inf_commute maddux_3_11_pp path_compression_invariant_def) + also have "... = (w \ p)\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w \ (-w \ p)\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: mult_right_dist_sup) + also have "... \ w\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w \ (-w \ p)\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w" + using semiring.add_right_mono comp_isotone conv_isotone by auto + also have "... = (-w \ p)\<^sup>T * ?p\<^sup>T\<^sup>\ * p\<^sup>T * w" + using 9 by simp + also have "... \ ?p\<^sup>T\<^sup>+ * p\<^sup>T * w" + by (simp add: conv_isotone mult_left_isotone) + also have "... \ ?p\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: comp_isotone star.left_plus_below_circ) + finally have "p\<^sup>T\<^sup>\ * p\<^sup>T * w \ ?p\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (metis comp_associative star.circ_loop_fixpoint star_left_induct sup_commute sup_least sup_left_divisibility) + thus "y \ ?p\<^sup>T\<^sup>\ * (p[[w]])" + using 6 by (simp add: star_simulation_right_equal mult_assoc) + qed + have 10: "acyclic (?p \ -1)" + using 1 update_acyclic_1 path_compression_invariant_def path_compression_precondition_def by auto + have "?p[[p\<^sup>T\<^sup>+ * w]] \ p\<^sup>T\<^sup>+ * w" + proof - + have "(w\<^sup>T \ y) * p\<^sup>T\<^sup>+ * w = y \ w\<^sup>T * p\<^sup>T\<^sup>+ * w" + using 1 by (metis (no_types, hide_lams) path_compression_invariant_def path_compression_precondition_def inf_commute vector_inf_comp) + hence "?p[[p\<^sup>T\<^sup>+ * w]] = (y \ w\<^sup>T * p\<^sup>T\<^sup>+ * w) \ (-w\<^sup>T \ p\<^sup>T) * p\<^sup>T\<^sup>+ * w" + by (simp add: comp_associative conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup) + also have "... \ y \ (-w\<^sup>T \ p\<^sup>T) * p\<^sup>T\<^sup>+ * w" + using sup_left_isotone by auto + also have "... \ y \ p\<^sup>T * p\<^sup>T\<^sup>+ * w" + using mult_left_isotone sup_right_isotone by auto + also have "... \ y \ p\<^sup>T\<^sup>+ * w" + using semiring.add_left_mono mult_left_isotone mult_right_isotone star.left_plus_below_circ by auto + also have "... = p\<^sup>T\<^sup>+ * w" + using 6 by (simp add: sup_absorb2) + finally show ?thesis + by simp + qed + hence 11: "?p\<^sup>T\<^sup>\ * (p[[w]]) \ p\<^sup>T\<^sup>+ * w" + using star_left_induct by (simp add: mult_left_isotone star.circ_mult_increasing) + hence 12: "?p\<^sup>T\<^sup>+ * (p[[w]]) \ p\<^sup>T\<^sup>+ * w" + using dual_order.trans mult_left_isotone star.left_plus_below_circ by blast + have 13: "?p[[x]] = y \ y \ x \ ?p\<^sup>T\<^sup>+ * (p[[w]]) \ -x" + proof (cases "w = x") + case True + hence "?p[[x]] = (w\<^sup>T \ y) * w \ (-w\<^sup>T \ p\<^sup>T) * w" + by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup) + also have "... = (w\<^sup>T \ y) * w \ p\<^sup>T * (-w \ w)" + using 1 by (metis (no_types, lifting) conv_complement inf.sup_monoid.add_commute path_compression_invariant_def covector_inf_comp_3 vector_complement_closed) + also have "... = (w\<^sup>T \ y) * w" + by simp + also have "... = y * w" + using 1 inf.sup_monoid.add_commute path_compression_invariant_def covector_inf_comp_3 by simp + also have "... = y" + using 1 by (metis comp_associative path_compression_precondition_def path_compression_invariant_def) + finally show ?thesis + using 4 8 12 True pseudo_complement inf.sup_monoid.add_commute order.trans by blast + next + case False + have "?p[[x]] = (w\<^sup>T \ y) * x \ (-w\<^sup>T \ p\<^sup>T) * x" + by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup) + also have "... = y * (w \ x) \ p\<^sup>T * (-w \ x)" + using 1 by (metis (no_types, lifting) conv_complement inf.sup_monoid.add_commute path_compression_invariant_def covector_inf_comp_3 vector_complement_closed) + also have "... = p\<^sup>T * (-w \ x)" + using 1 False path_compression_invariant_def path_compression_precondition_def distinct_points by auto + also have "... = y" + using 1 False path_compression_invariant_def path_compression_precondition_def distinct_points inf.absorb2 pseudo_complement by auto + finally show ?thesis + using 1 12 False path_compression_invariant_def by auto + qed + thus "p[[w]] \ x \ ?p[[x]] = y \ y \ x \ ?p\<^sup>T\<^sup>+ * (p[[w]]) \ -x" + by simp + have 14: "?p\<^sup>T\<^sup>\ * x = x \ y" + proof (rule antisym) + have "?p\<^sup>T * (x \ y) = y \ ?p\<^sup>T * y" + using 13 by (simp add: mult_left_dist_sup) + also have "... = y \ (w\<^sup>T \ y) * y \ (-w\<^sup>T \ p\<^sup>T) * y" + by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup sup_assoc) + also have "... \ y \ (w\<^sup>T \ y) * y \ p\<^sup>T * y" + using mult_left_isotone sup_right_isotone by auto + also have "... = y \ (w\<^sup>T \ y) * y" + using 1 by (smt sup.cobounded1 sup_absorb1 path_compression_invariant_def path_compression_precondition_def root_successor_loop) + also have "... \ y \ y * y" + using mult_left_isotone sup_right_isotone by auto + also have "... = y" + using 1 by (metis mult_semi_associative sup_absorb1 path_compression_invariant_def path_compression_precondition_def) + also have "... \ x \ y" + by simp + finally show "?p\<^sup>T\<^sup>\ * x \ x \ y" + by (simp add: star_left_induct) + next + show "x \ y \ ?p\<^sup>T\<^sup>\ * x" + using 13 by (metis mult_left_isotone star.circ_increasing star.circ_loop_fixpoint sup.boundedI sup_ge2) + qed + have 15: "y = root ?p x" + proof - + have "(p \ 1) * y = (p \ 1) * (p \ 1) * p\<^sup>T\<^sup>\ * x" + using 1 path_compression_invariant_def path_compression_precondition_def root_var mult_assoc by auto + also have "... = (p \ 1) * p\<^sup>T\<^sup>\ * x" + using coreflexive_idempotent by auto + finally have 16: "(p \ 1) * y = y" + using 1 path_compression_invariant_def path_compression_precondition_def root_var by auto + have 17: "(p \ 1) * x \ y" + using 1 by (metis (no_types, lifting) comp_right_one mult_left_isotone mult_right_isotone star.circ_reflexive path_compression_invariant_def path_compression_precondition_def root_var) + have "root ?p x = (?p \ 1) * (x \ y)" + using 14 by (metis mult_assoc root_var) + also have "... = (w \ y\<^sup>T \ 1) * (x \ y) \ (-w \ p \ 1) * (x \ y)" + by (simp add: inf_sup_distrib2 semiring.distrib_right) + also have "... = (w \ 1 \ y\<^sup>T) * (x \ y) \ (-w \ p \ 1) * (x \ y)" + by (simp add: inf.left_commute inf.sup_monoid.add_commute) + also have "... = (w \ 1) * (y \ (x \ y)) \ (-w \ p \ 1) * (x \ y)" + using 1 by (metis (no_types, lifting) path_compression_invariant_def path_compression_precondition_def covector_inf_comp_3) + also have "... = (w \ 1) * y \ (-w \ p \ 1) * (x \ y)" + by (simp add: inf.absorb1) + also have "... = (w \ 1 * y) \ (-w \ (p \ 1) * (x \ y))" + using 1 by (metis (no_types, lifting) inf_assoc vector_complement_closed path_compression_invariant_def vector_inf_comp) + also have "... = (w \ y) \ (-w \ ((p \ 1) * x \ y))" + using 16 by (simp add: mult_left_dist_sup) + also have "... = (w \ y) \ (-w \ y)" + using 17 by (simp add: sup.absorb2) + also have "... = y" + using 1 by (metis id_apply bijective_regular comp_inf.mult_right_dist_sup comp_inf.vector_conv_covector inf_top.right_neutral regular_complement_top path_compression_invariant_def) + finally show ?thesis + by simp + qed + show "path_compression_precondition ?p x y" + using 1 3 10 15 path_compression_invariant_def path_compression_precondition_def by auto + show "vector (p[[w]])" + using 2 by simp + show "injective (p[[w]])" + using 2 by simp + show "surjective (p[[w]])" + using 2 by simp + have "w \ p \ 1 \ w \ w\<^sup>T \ p" + by (metis inf.boundedE inf.boundedI inf.cobounded1 inf.cobounded2 one_inf_conv) + also have "... = w * w\<^sup>T \ p" + using 1 vector_covector path_compression_invariant_def by auto + also have "... \ -p\<^sup>T\<^sup>+ \ p" + using 7 by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute) + finally have "w \ p \ 1 = bot" + by (metis (no_types, hide_lams) conv_dist_inf coreflexive_symmetric inf.absorb1 inf.boundedE inf.cobounded2 pseudo_complement star.circ_mult_increasing) + also have "w \ y\<^sup>T \ 1 = bot" + using 5 antisymmetric_bot_closed asymmetric_bot_closed comp_inf.schroeder_2 inf.absorb1 one_inf_conv by fastforce + finally have "w \ p \ 1 = w \ y\<^sup>T \ 1" + by simp + thus "?p \ 1 = p0 \ 1" + using 1 by (metis bijective_regular comp_inf.semiring.distrib_left inf.sup_monoid.add_commute maddux_3_11_pp path_compression_invariant_def) + show "fc ?p = fc p0" + proof - + have "p[[w]] = p\<^sup>T * (w \ p\<^sup>\ * y)" + using 1 by (metis (no_types, lifting) bijective_reverse conv_star_commute inf.absorb1 path_compression_invariant_def path_compression_precondition_def) + also have "... = p\<^sup>T * (w \ p\<^sup>\) * y" + using 1 vector_inf_comp path_compression_invariant_def mult_assoc by auto + also have "... = p\<^sup>T * ((w \ 1) \ (w \ p) * (-w \ p)\<^sup>\) * y" + using 1 omit_redundant_points path_compression_invariant_def by auto + also have "... = p\<^sup>T * (w \ 1) * y \ p\<^sup>T * (w \ p) * (-w \ p)\<^sup>\ * y" + by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup) + also have "... \ p\<^sup>T * y \ p\<^sup>T * (w \ p) * (-w \ p)\<^sup>\ * y" + by (metis semiring.add_right_mono comp_isotone eq_iff inf.cobounded1 inf.sup_monoid.add_commute mult_1_right) + also have "... = y \ p\<^sup>T * (w \ p) * (-w \ p)\<^sup>\ * y" + using 1 path_compression_invariant_def path_compression_precondition_def root_successor_loop by fastforce + also have "... \ y \ p\<^sup>T * p * (-w \ p)\<^sup>\ * y" + using comp_isotone sup_right_isotone by auto + also have "... \ y \ (-w \ p)\<^sup>\ * y" + using 1 by (metis (no_types, lifting) mult_left_isotone star.circ_circ_mult star_involutive star_one sup_right_isotone path_compression_invariant_def path_compression_precondition_def) + also have "... = (-w \ p)\<^sup>\ * y" + by (metis star.circ_loop_fixpoint sup.left_idem sup_commute) + finally have 18: "p[[w]] \ (-w \ p)\<^sup>\ * y" + by simp + have "p\<^sup>T * (-w \ p)\<^sup>\ * y = p\<^sup>T * y \ p\<^sup>T * (-w \ p) * (-w \ p)\<^sup>\ * y" + by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute) + also have "... = y \ p\<^sup>T * (-w \ p) * (-w \ p)\<^sup>\ * y" + using 1 path_compression_invariant_def path_compression_precondition_def root_successor_loop by fastforce + also have "... \ y \ p\<^sup>T * p * (-w \ p)\<^sup>\ * y" + using comp_isotone sup_right_isotone by auto + also have "... \ y \ (-w \ p)\<^sup>\ * y" + using 1 by (metis (no_types, lifting) mult_left_isotone star.circ_circ_mult star_involutive star_one sup_right_isotone path_compression_invariant_def path_compression_precondition_def) + also have "... = (-w \ p)\<^sup>\ * y" + by (metis star.circ_loop_fixpoint sup.left_idem sup_commute) + finally have 19: "p\<^sup>T\<^sup>\ * p\<^sup>T * w \ (-w \ p)\<^sup>\ * y" + using 18 by (simp add: comp_associative star_left_induct) + have "w\<^sup>T \ p\<^sup>T = p\<^sup>T * (w\<^sup>T \ 1)" + using 1 by (metis conv_dist_comp conv_dist_inf equivalence_one_closed vector_inf_one_comp path_compression_invariant_def) + also have "... \ p[[w]]" + by (metis comp_right_subdist_inf inf.boundedE inf.sup_monoid.add_commute one_inf_conv) + also have "... \ p\<^sup>T\<^sup>\ * p\<^sup>T * w" + by (simp add: mult_left_isotone star.circ_mult_increasing_2) + also have "... \ (-w \ p)\<^sup>\ * y" + using 19 by simp + finally have "w \ p \ y\<^sup>T * (-w \ p)\<^sup>T\<^sup>\" + by (metis conv_dist_comp conv_dist_inf conv_involutive conv_isotone conv_star_commute) + hence "w \ p \ (w \ y\<^sup>T) * (-w \ p)\<^sup>T\<^sup>\" + using 1 by (metis inf.absorb1 inf.left_commute inf.left_idem inf.orderI vector_inf_comp path_compression_invariant_def) + also have "... \ (w \ y\<^sup>T) * ?p\<^sup>T\<^sup>\" + by (simp add: conv_isotone mult_right_isotone star_isotone) + also have "... \ ?p * ?p\<^sup>T\<^sup>\" + by (simp add: mult_left_isotone) + also have "... \ fc ?p" + by (simp add: mult_left_isotone star.circ_increasing) + finally have 20: "w \ p \ fc ?p" + by simp + have "-w \ p \ ?p" + by simp + also have "... \ fc ?p" + by (simp add: fc_increasing) + finally have "(w \ -w) \ p \ fc ?p" + using 20 by (simp add: comp_inf.semiring.distrib_left inf.sup_monoid.add_commute) + hence "p \ fc ?p" + using 1 by (metis (no_types, hide_lams) bijective_regular comp_inf.semiring.distrib_left inf.sup_monoid.add_commute maddux_3_11_pp path_compression_invariant_def) + hence 21: "fc p \ fc ?p" + using 3 fc_idempotent fc_isotone by fastforce + have "?p \ (w \ y\<^sup>T) \ p" + using sup_right_isotone by auto + also have "... = w * y\<^sup>T \ p" + using 1 path_compression_invariant_def path_compression_precondition_def vector_covector by auto + also have "... \ p\<^sup>\ \ p" + using 1 by (metis (no_types, lifting) conv_dist_comp conv_involutive conv_isotone conv_star_commute le_supI shunt_bijective star.circ_increasing sup_absorb1 path_compression_invariant_def) + also have "... \ fc p" + using fc_increasing star.circ_back_loop_prefixpoint by auto + finally have "fc ?p \ fc p" + using 1 by (metis (no_types, lifting) path_compression_invariant_def path_compression_precondition_def fc_idempotent fc_isotone) + thus ?thesis + using 1 21 path_compression_invariant_def by simp + qed + show "card ?t < n" + proof - + have "?p\<^sup>T * p\<^sup>T\<^sup>\ * w = (w\<^sup>T \ y) * p\<^sup>T\<^sup>\ * w \ (-w\<^sup>T \ p\<^sup>T) * p\<^sup>T\<^sup>\ * w" + by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup) + also have "... \ (w\<^sup>T \ y) * p\<^sup>T\<^sup>\ * w \ p\<^sup>T * p\<^sup>T\<^sup>\ * w" + using mult_left_isotone sup_right_isotone by auto + also have "... \ (w\<^sup>T \ y) * p\<^sup>T\<^sup>\ * w \ p\<^sup>T\<^sup>\ * w" + using mult_left_isotone star.left_plus_below_circ sup_right_isotone by blast + also have "... \ y * p\<^sup>T\<^sup>\ * w \ p\<^sup>T\<^sup>\ * w" + using semiring.add_right_mono mult_left_isotone by auto + also have "... \ y * top \ p\<^sup>T\<^sup>\ * w" + by (simp add: comp_associative le_supI1 mult_right_isotone) + also have "... = p\<^sup>T\<^sup>\ * w" + using 1 path_compression_invariant_def path_compression_precondition_def sup_absorb2 by auto + finally have "?p\<^sup>T\<^sup>\ * p\<^sup>T * w \ p\<^sup>T\<^sup>\ * w" + using 11 by (metis dual_order.trans star.circ_loop_fixpoint sup_commute sup_ge2 mult_assoc) + hence 22: "?t \ ?s" + using order_lesseq_imp mult_assoc by auto + have 23: "w \ ?s" + using 1 bijective_regular path_compression_invariant_def eq_iff star.circ_loop_fixpoint by auto + have 24: "\ w \ ?t" + proof + assume "w \ ?t" + hence 25: "w \ (?p\<^sup>T \ -1)\<^sup>\ * (p[[w]])" + using reachable_without_loops by auto + hence "p[[w]] \ (?p \ -1)\<^sup>\ * w" + using 1 2 by (metis (no_types, hide_lams) bijective_reverse conv_star_commute reachable_without_loops path_compression_invariant_def) + also have "... \ p\<^sup>\ * w" + proof - + have "p\<^sup>T\<^sup>\ * y = y" + using 1 path_compression_invariant_def path_compression_precondition_def root_transitive_successor_loop by fastforce + hence "y\<^sup>T * p\<^sup>\ * w = y\<^sup>T * w" + by (metis conv_dist_comp conv_involutive conv_star_commute) + also have "... = bot" + using 1 5 by (metis (no_types, hide_lams) conv_dist_comp conv_dist_inf equivalence_top_closed inf_top.right_neutral schroeder_2 symmetric_bot_closed path_compression_invariant_def) + finally have 26: "y\<^sup>T * p\<^sup>\ * w = bot" + by simp + have "(?p \ -1) * p\<^sup>\ * w = (w \ y\<^sup>T \ -1) * p\<^sup>\ * w \ (-w \ p \ -1) * p\<^sup>\ * w" + by (simp add: comp_inf.mult_right_dist_sup mult_right_dist_sup) + also have "... \ (w \ y\<^sup>T \ -1) * p\<^sup>\ * w \ p * p\<^sup>\ * w" + by (meson inf_le1 inf_le2 mult_left_isotone order_trans sup_right_isotone) + also have "... \ (w \ y\<^sup>T \ -1) * p\<^sup>\ * w \ p\<^sup>\ * w" + using mult_left_isotone star.left_plus_below_circ sup_right_isotone by blast + also have "... \ y\<^sup>T * p\<^sup>\ * w \ p\<^sup>\ * w" + by (meson inf_le1 inf_le2 mult_left_isotone order_trans sup_left_isotone) + also have "... = p\<^sup>\ * w" + using 26 by simp + finally show ?thesis + by (metis comp_associative le_supI star.circ_loop_fixpoint sup_ge2 star_left_induct) + qed + finally have "w \ p\<^sup>T\<^sup>\ * p\<^sup>T * w" + using 11 25 reachable_without_loops star_plus by auto + thus False + using 1 7 by (metis inf.le_iff_sup le_bot pseudo_complement schroeder_4_p semiring.mult_zero_right star.circ_plus_same path_compression_invariant_def) + qed + have "card ?t < card ?s" + apply (rule psubset_card_mono) + subgoal using finite_regular by simp + subgoal using 22 23 24 by auto + done + thus ?thesis + using 1 by simp + qed + qed +qed + +lemma path_compression_3: + "path_compression_invariant p x y p0 w \ y = p[[w]] \ path_compression_postcondition p x (p[[w]]) p0" + using path_compression_invariant_def path_compression_postcondition_def path_compression_precondition_def by auto + +theorem path_compression: + "VARS p t w + [ path_compression_precondition p x y \ p0 = p ] + w := x; + WHILE y \ p[[w]] + INV { path_compression_invariant p x y p0 w } + VAR { card { z . regular z \ z \ p\<^sup>T\<^sup>\ * w } } + DO t := w; + w := p[[w]]; + p[t] := y + OD + [ path_compression_postcondition p x y p0 ]" + apply vcg_tc_simp + apply (rule path_compression_1, force) + apply (rule path_compression_2, force) + by (fact path_compression_3) + +lemma path_compression_exists: + "path_compression_precondition p x y \ \p' . path_compression_postcondition p' x y p" + using tc_extract_function path_compression by blast + +definition "path_compression p x y \ (SOME p' . path_compression_postcondition p' x y p)" + +lemma path_compression_function: + assumes "path_compression_precondition p x y" + and "p' = path_compression p x y" + shows "path_compression_postcondition p' x y p" + by (metis assms path_compression_def path_compression_exists someI) + +subsection \Find-Set with Path Compression\ + +text \ +We sequentially combine find-set and path compression. +We consider implementations which use the previously derived functions and implementations which unfold their definitions. +\ + +theorem find_set_path_compression: + "VARS p y + [ find_set_precondition p x \ p0 = p ] + y := find_set p x; + p := path_compression p x y + [ path_compression_postcondition p x y p0 ]" + apply vcg_tc_simp + using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by fastforce + +theorem find_set_path_compression_1: + "VARS p t w y + [ find_set_precondition p x \ p0 = p ] + y := find_set p x; + w := x; + WHILE y \ p[[w]] + INV { path_compression_invariant p x y p0 w } + VAR { card { z . regular z \ z \ p\<^sup>T\<^sup>\ * w } } + DO t := w; + w := p[[w]]; + p[t] := y + OD + [ path_compression_postcondition p x y p0 ]" + apply vcg_tc_simp + using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_1 path_compression_precondition_def + apply fastforce + apply (rule path_compression_2, force) + by (rule path_compression_3, force) + +theorem find_set_path_compression_2: + "VARS p y + [ find_set_precondition p x \ p0 = p ] + y := x; + WHILE y \ p[[y]] + INV { find_set_invariant p x y \ p0 = p } + VAR { card { z . regular z \ z \ p\<^sup>T\<^sup>\ * y } } + DO y := p[[y]] + OD; + p := path_compression p x y + [ path_compression_postcondition p x y p0 ]" + apply vcg_tc_simp + apply (simp add: find_set_1) + using find_set_2 apply blast + by (smt find_set_3 find_set_invariant_def find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def) + +theorem find_set_path_compression_3: + "VARS p t w y + [ find_set_precondition p x \ p0 = p ] + y := x; + WHILE y \ p[[y]] + INV { find_set_invariant p x y \ p0 = p } + VAR { card { z . regular z \ z \ p\<^sup>T\<^sup>\ * y } } + DO y := p[[y]] + OD; + w := x; + WHILE y \ p[[w]] + INV { path_compression_invariant p x y p0 w } + VAR { card { z . regular z \ z \ p\<^sup>T\<^sup>\ * w } } + DO t := w; + w := p[[w]]; + p[t] := y + OD + [ path_compression_postcondition p x y p0 ]" + apply vcg_tc_simp + apply (simp add: find_set_1) + using find_set_2 apply blast + using find_set_3 find_set_invariant_def find_set_postcondition_def find_set_precondition_def path_compression_invariant_def path_compression_precondition_def apply blast + apply (rule path_compression_2, force) + by (rule path_compression_3, force) + +text \ +Find-set with path compression returns two results: the representative of the tree and the modified disjoint-set forest. +\ + +lemma find_set_path_compression_exists: + "find_set_precondition p x \ \p' y . path_compression_postcondition p' x y p" + using tc_extract_function find_set_path_compression by blast + +definition "find_set_path_compression p x \ (SOME (p',y) . path_compression_postcondition p' x y p)" + +lemma find_set_path_compression_function: + assumes "find_set_precondition p x" + and "(p',y) = find_set_path_compression p x" + shows "path_compression_postcondition p' x y p" +proof - + let ?P = "\(p',y) . path_compression_postcondition p' x y p" + have "?P (SOME z . ?P z)" + apply (unfold some_eq_ex) + using assms(1) find_set_path_compression_exists by simp + thus ?thesis + using assms(2) find_set_path_compression_def by auto +qed + +subsection \Union-Sets\ + +text \ +We only consider a naive union-sets operation (without ranks). +The semantics is the equivalence closure obtained after adding the link between the two given nodes, +which requires those two elements to be in the same set. +The implementation uses temporary variable \t\ to store the two results returned by find-set with path compression. +The disjoint-set forest, which keeps being updated, is threaded through the sequence of operations. +\ + +definition "union_sets_precondition p x y \ disjoint_set_forest p \ point x \ point y" +definition "union_sets_postcondition p x y p0 \ union_sets_precondition p x y \ fc p = wcc (p0 \ x * y\<^sup>T)" + +theorem union_sets: + "VARS p r s t + [ union_sets_precondition p x y \ p0 = p ] + t := find_set_path_compression p x; + p := fst t; + r := snd t; + t := find_set_path_compression p y; + p := fst t; + s := snd t; + p[r] := s + [ union_sets_postcondition p x y p0 ]" +proof vcg_tc_simp + fix p + let ?t1 = "find_set_path_compression p x" + let ?p1 = "fst ?t1" + let ?r = "snd ?t1" + let ?t2 = "find_set_path_compression ?p1 y" + let ?p2 = "fst ?t2" + let ?s = "snd ?t2" + let ?p = "?p2[?r\?s]" + assume 1: "union_sets_precondition p x y \ p0 = p" + show "union_sets_postcondition ?p x y p" + proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI) + have "path_compression_postcondition ?p1 x ?r p" + using 1 by (simp add: find_set_precondition_def union_sets_precondition_def find_set_path_compression_function) + hence 2: "disjoint_set_forest ?p1 \ point ?r \ ?r = root ?p1 x \ ?p1 \ 1 = p \ 1 \ fc ?p1 = fc p" + using path_compression_precondition_def path_compression_postcondition_def by auto + hence "path_compression_postcondition ?p2 y ?s ?p1" + using 1 by (simp add: find_set_precondition_def union_sets_precondition_def find_set_path_compression_function) + hence 3: "disjoint_set_forest ?p2 \ point ?s \ ?s = root ?p2 y \ ?p2 \ 1 = ?p1 \ 1 \ fc ?p2 = fc ?p1" + using path_compression_precondition_def path_compression_postcondition_def by auto + hence 4: "fc ?p2 = fc p" + using 2 by simp + show 5: "univalent ?p" + using 2 3 update_univalent by blast + show "total ?p" + using 2 3 bijective_regular update_total by blast + show "acyclic (?p \ -1)" + proof (cases "?r = ?s") + case True + thus ?thesis + using 3 update_acyclic_3 by fastforce + next + case False + hence "bot = ?r \ ?s" + using 2 3 distinct_points by blast + also have "... = ?r \ ?p2\<^sup>T\<^sup>\ * ?s" + using 3 root_transitive_successor_loop by force + finally have "?s \ ?p2\<^sup>\ * ?r = bot" + using schroeder_1 conv_star_commute inf.sup_monoid.add_commute by fastforce + thus ?thesis + using 2 3 update_acyclic_2 by blast + qed + show "vector x" + using 1 by (simp add: union_sets_precondition_def) + show "injective x" + using 1 by (simp add: union_sets_precondition_def) + show "surjective x" + using 1 by (simp add: union_sets_precondition_def) + show "vector y" + using 1 by (simp add: union_sets_precondition_def) + show "injective y" + using 1 by (simp add: union_sets_precondition_def) + show "surjective y" + using 1 by (simp add: union_sets_precondition_def) + show "fc ?p = wcc (p \ x * y\<^sup>T)" + proof (rule antisym) + have "?r = ?p1[[?r]]" + using 2 root_successor_loop by force + hence "?r * ?r\<^sup>T \ ?p1\<^sup>T" + using 2 eq_refl shunt_bijective by blast + hence "?r * ?r\<^sup>T \ ?p1" + using 2 conv_order coreflexive_symmetric by fastforce + hence "?r * ?r\<^sup>T \ ?p1 \ 1" + using 2 inf.boundedI by blast + also have "... = ?p2 \ 1" + using 3 by simp + finally have "?r * ?r\<^sup>T \ ?p2" + by simp + hence "?r \ ?p2 * ?r" + using 2 shunt_bijective by blast + hence 6: "?p2[[?r]] \ ?r" + using 3 shunt_mapping by blast + have "?r \ ?p2 \ ?r * (top \ ?r\<^sup>T * ?p2)" + using 2 by (metis dedekind_1) + also have "... = ?r * ?r\<^sup>T * ?p2" + by (simp add: mult_assoc) + also have "... \ ?r * ?r\<^sup>T" + using 6 by (metis comp_associative conv_dist_comp conv_involutive conv_order mult_right_isotone) + also have "... \ 1" + using 2 by blast + finally have 7: "?r \ ?p2 \ 1" + by simp + have "p \ wcc p" + by (simp add: star.circ_sub_dist_1) + also have "... = wcc ?p2" + using 4 by (simp add: star_decompose_1) + also have 8: "... \ wcc ?p" + proof - + have "wcc ?p2 = wcc ((-?r \ ?p2) \ (?r \ ?p2))" + using 2 by (metis bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp) + also have "... \ wcc ((-?r \ ?p2) \ 1)" + using 7 wcc_isotone sup_right_isotone by simp + also have "... = wcc (-?r \ ?p2)" + using wcc_with_loops by simp + also have "... \ wcc ?p" + using wcc_isotone sup_ge2 by blast + finally show ?thesis + by simp + qed + finally have 9: "p \ wcc ?p" + by force + have "?r \ ?p1\<^sup>T\<^sup>\ * x" + using 2 by simp + hence 10: "?r * x\<^sup>T \ ?p1\<^sup>T\<^sup>\" + using 1 shunt_bijective union_sets_precondition_def by blast + hence "x * ?r\<^sup>T \ ?p1\<^sup>\" + using conv_dist_comp conv_order conv_star_commute by force + also have "... \ wcc ?p1" + by (simp add: star.circ_sub_dist) + also have "... = wcc ?p2" + using 2 3 by (simp add: fc_wcc) + also have "... \ wcc ?p" + using 8 by simp + finally have 11: "x * ?r\<^sup>T \ wcc ?p" + by simp + have 12: "?r * ?s\<^sup>T \ wcc ?p" + using 2 3 star.circ_sub_dist_1 sup_assoc vector_covector by auto + have "?s \ ?p2\<^sup>T\<^sup>\ * y" + using 3 by simp + hence 13: "?s * y\<^sup>T \ ?p2\<^sup>T\<^sup>\" + using 1 shunt_bijective union_sets_precondition_def by blast + also have "... \ wcc ?p2" + using star_isotone sup_ge2 by blast + also have "... \ wcc ?p" + using 8 by simp + finally have 14: "?s * y\<^sup>T \ wcc ?p" + by simp + have "x \ x * ?r\<^sup>T * ?r \ y \ y * ?s\<^sup>T * ?s" + using 2 3 shunt_bijective by blast + hence "x * y\<^sup>T \ x * ?r\<^sup>T * ?r * (y * ?s\<^sup>T * ?s)\<^sup>T" + using comp_isotone conv_isotone by blast + also have "... = x * ?r\<^sup>T * ?r * ?s\<^sup>T * ?s * y\<^sup>T" + by (simp add: comp_associative conv_dist_comp) + also have "... \ wcc ?p * (?r * ?s\<^sup>T) * (?s * y\<^sup>T)" + using 11 by (metis mult_left_isotone mult_assoc) + also have "... \ wcc ?p * wcc ?p * (?s * y\<^sup>T)" + using 12 by (metis mult_left_isotone mult_right_isotone) + also have "... \ wcc ?p * wcc ?p * wcc ?p" + using 14 by (metis mult_right_isotone) + also have "... = wcc ?p" + by (simp add: star.circ_transitive_equal) + finally have "p \ x * y\<^sup>T \ wcc ?p" + using 9 by simp + hence "wcc (p \ x * y\<^sup>T) \ wcc ?p" + using wcc_below_wcc by simp + thus "wcc (p \ x * y\<^sup>T) \ fc ?p" + using 5 fc_wcc by simp + have "-?r \ ?p2 \ wcc ?p2" + by (simp add: inf.coboundedI2 star.circ_sub_dist_1) + also have "... = wcc p" + using 4 by (simp add: star_decompose_1) + also have "... \ wcc (p \ x * y\<^sup>T)" + by (simp add: wcc_isotone) + finally have 15: "-?r \ ?p2 \ wcc (p \ x * y\<^sup>T)" + by simp + have "?r * x\<^sup>T \ wcc ?p1" + using 10 inf.order_trans star.circ_sub_dist sup_commute by fastforce + also have "... = wcc p" + using 2 by (simp add: star_decompose_1) + also have "... \ wcc (p \ x * y\<^sup>T)" + by (simp add: wcc_isotone) + finally have 16: "?r * x\<^sup>T \ wcc (p \ x * y\<^sup>T)" + by simp + have 17: "x * y\<^sup>T \ wcc (p \ x * y\<^sup>T)" + using le_supE star.circ_sub_dist_1 by blast + have "y * ?s\<^sup>T \ ?p2\<^sup>\" + using 13 conv_dist_comp conv_order conv_star_commute by fastforce + also have "... \ wcc ?p2" + using star.circ_sub_dist sup_commute by fastforce + also have "... = wcc p" + using 4 by (simp add: star_decompose_1) + also have "... \ wcc (p \ x * y\<^sup>T)" + by (simp add: wcc_isotone) + finally have 18: "y * ?s\<^sup>T \ wcc (p \ x * y\<^sup>T)" + by simp + have "?r \ ?r * x\<^sup>T * x \ ?s \ ?s * y\<^sup>T * y" + using 1 shunt_bijective union_sets_precondition_def by blast + hence "?r * ?s\<^sup>T \ ?r * x\<^sup>T * x * (?s * y\<^sup>T * y)\<^sup>T" + using comp_isotone conv_isotone by blast + also have "... = ?r * x\<^sup>T * x * y\<^sup>T * y * ?s\<^sup>T" + by (simp add: comp_associative conv_dist_comp) + also have "... \ wcc (p \ x * y\<^sup>T) * (x * y\<^sup>T) * (y * ?s\<^sup>T)" + using 16 by (metis mult_left_isotone mult_assoc) + also have "... \ wcc (p \ x * y\<^sup>T) * wcc (p \ x * y\<^sup>T) * (y * ?s\<^sup>T)" + using 17 by (metis mult_left_isotone mult_right_isotone) + also have "... \ wcc (p \ x * y\<^sup>T) * wcc (p \ x * y\<^sup>T) * wcc (p \ x * y\<^sup>T)" + using 18 by (metis mult_right_isotone) + also have "... = wcc (p \ x * y\<^sup>T)" + by (simp add: star.circ_transitive_equal) + finally have "?p \ wcc (p \ x * y\<^sup>T)" + using 2 3 15 vector_covector by auto + hence "wcc ?p \ wcc (p \ x * y\<^sup>T)" + using wcc_below_wcc by blast + thus "fc ?p \ wcc (p \ x * y\<^sup>T)" + using 5 fc_wcc by simp + qed + qed +qed + +lemma union_sets_exists: + "union_sets_precondition p x y \ \p' . union_sets_postcondition p' x y p" + using tc_extract_function union_sets by blast + +definition "union_sets p x y \ (SOME p' . union_sets_postcondition p' x y p)" + +lemma union_sets_function: + assumes "union_sets_precondition p x y" + and "p' = union_sets p x y" + shows "union_sets_postcondition p' x y p" + by (metis assms union_sets_def union_sets_exists someI) + +end + +end + diff --git a/thys/Relational_Disjoint_Set_Forests/ROOT b/thys/Relational_Disjoint_Set_Forests/ROOT new file mode 100644 --- /dev/null +++ b/thys/Relational_Disjoint_Set_Forests/ROOT @@ -0,0 +1,16 @@ +chapter AFP + +session Relational_Disjoint_Set_Forests (AFP) = Stone_Kleene_Relation_Algebras + + + options [timeout = 600] + + sessions + Aggregation_Algebras + + theories + Disjoint_Set_Forests + + document_files + "root.tex" + "root.bib" + diff --git a/thys/Relational_Disjoint_Set_Forests/document/root.bib b/thys/Relational_Disjoint_Set_Forests/document/root.bib new file mode 100644 --- /dev/null +++ b/thys/Relational_Disjoint_Set_Forests/document/root.bib @@ -0,0 +1,199 @@ +@STRING{afp = {Archive of Formal Proofs}} +@STRING{fac = {Formal Aspects of Computing}} +@STRING{is = {Information Sciences}} +@STRING{jlamp = {Journal of Logical and Algebraic Methods in Programming}} +@STRING{lncs = {Lecture Notes in Computer Science}} +@STRING{mitp = {MIT Press}} +@STRING{sv = {Springer}} + +@Book{BackWright1998, + author = {Back, R.-J. and von Wright, J.}, + title = {Refinement Calculus}, + publisher = sv, + address = {New York}, + year = 1998, + note = {} +} + +@Article{BackhouseCarre1975, + author = {Backhouse, R. C. and Carr{\'e}, B. A.}, + title = {Regular Algebra Applied to Path-finding Problems}, + journal = {Journal of the Institute of Mathematics and its Applications}, + volume = 15, + number = 2, + pages = {161--186}, + year = 1975, + note = {} +} + +@Article{Berghammer1999, + author = {Berghammer, R.}, + title = {Combining relational calculus and the {Dijkstra--Gries} method for deriving relational programs}, + journal = is, + volume = 119, + number = {3--4}, + pages = {155--171}, + year = 1999, + note = {} +} + +@InProceedings{BerghammerKargerWolf1998, + author = {Berghammer, R. and von Karger, B. and Wolf, A.}, + title = {Relation-Algebraic Derivation of Spanning Tree Algorithms}, + editor = {Jeuring, J.}, + booktitle = {Mathematics of Program Construction (MPC 1998)}, + publisher = sv, + series = lncs, + volume = 1422, + pages = {23--43}, + year = 1998, + note = {} +} + +@InProceedings{BerghammerStruth2010, + author = {Berghammer, R. and Struth, G.}, + title = {On Automated Program Construction and Verification}, + editor = {Bolduc, C. and Desharnais, J. and Ktari, B.}, + booktitle = {Mathematics of Program Construction (MPC 2010)}, + publisher = sv, + series = lncs, + volume = 6120, + pages = {22--41}, + year = 2010, + note = {} +} + +@Book{CormenLeisersonRivest1990, + author = {Cormen, T. H. and Leiserson, C. E. and Rivest, R. L.}, + title = {Introduction to Algorithms}, + publisher = mitp, + year = 1990, + note = {} +} + +@Article{FosterGreenwaldMoorePierceSchmitt2007, + author = {Foster, J. N. and Greenwald, M. B. and Moore, J. T. and Pierce, B. C. and Schmitt, A.}, + title = {Combinators for Bidirectional Tree Transformations: A Linguistic Approach to the View-Update Problem}, + journal = toplas, + volume = 29, + number = {3:17}, + pages = {1--65}, + year = 2007, + note = {} +} + +@Article{GallerFisher1964, + author = {Galler, B. A. and Fisher, M. J.}, + title = {An Improved Equivalence Algorithm}, + journal = cacm, + volume = 7, + number = 5, + pages = {301--303}, + year = 1964, + note = {} +} + +@Book{GondranMinoux2008, + author = {Gondran, M. and Minoux, M.}, + title = {Graphs, Dioids and Semirings}, + publisher = sv, + year = 2008, + note = {} +} + +@Article{Guttmann2018c, + author = {Guttmann, W.}, + title = {Verifying Minimum Spanning Tree Algorithms with {Stone} Relation Algebras}, + journal = jlamp, + volume = 101, + pages = {132--150}, + year = 2018, + note = {} +} + +@InProceedings{Guttmann2020b, + author = {Guttmann, W.}, + title = {Verifying the Correctness of Disjoint-Set Forests with {Kleene} Relation Algebras}, + editor = {Fahrenberg, U. and Jipsen, P. and Winter, M.}, + booktitle = {Relational and Algebraic Methods in Computer Science (RAMiCS 2020)}, + publisher = sv, + series = lncs, + volume = 12062, + pages = {134--151}, + year = 2020, + note = {} +} + +@Article{HoefnerMoeller2012, + author = {H{\"o}fner, P. and M{\"o}ller, B.}, + title = {Dijkstra, {Floyd} and {Warshall} meet {Kleene}}, + journal = fac, + volume = 24, + number = 4, + pages = {459--476}, + year = 2012, + note = {} +} + +@Article{Kozen1994, + author = {Kozen, D.}, + title = {A completeness theorem for {Kleene} algebras and the algebra of regular events}, + journal = {Information and Computation}, + volume = 110, + number = 2, + pages = {366--390}, + year = 1994, + note = {} +} + +@Article{LammichMeis2012, + author = {Lammich, P. and Meis, R.}, + title = {A Separation Logic Framework for {I}mperative {HOL}}, + journal = afp, + year = 2012, + note = {} +} + +@InProceedings{Moeller1993, + author = {M{\"o}ller, B.}, + title = {Derivation of Graph and Pointer Algorithms}, + editor = {M{\"o}ller, B. and Partsch, H. A. and Schuman, S. A.}, + booktitle = {Formal Program Development}, + publisher = sv, + series = lncs, + volume = 755, + pages = {123--160}, + year = 1993, + note = {} +} + +@Article{Tarjan1975, + author = {Tarjan, R. E.}, + title = {Efficiency of a Good But Not Linear Set Union Algorithm}, + journal = jacm, + volume = 22, + number = 2, + pages = {215--225}, + year = 1975, + note = {} +} + +@Article{Tarski1941, + author = {Tarski, A.}, + title = {On the calculus of relations}, + journal = {The Journal of Symbolic Logic}, + volume = 6, + number = 3, + pages = {73--89}, + year = 1941, + note = {} +} + +@Article{Zhan2018, + author = {Zhan, B.}, + title = {Verifying Imperative Programs using {Auto2}}, + journal = afp, + year = 2018, + note = {} +} + diff --git a/thys/Relational_Disjoint_Set_Forests/document/root.tex b/thys/Relational_Disjoint_Set_Forests/document/root.tex new file mode 100644 --- /dev/null +++ b/thys/Relational_Disjoint_Set_Forests/document/root.tex @@ -0,0 +1,61 @@ +\documentclass[11pt,a4paper]{article} + +\usepackage{isabelle,isabellesym} +\usepackage{amssymb,ragged2e} +\usepackage{pdfsetup} + +\isabellestyle{it} +\renewenvironment{isamarkuptext}{\par\isastyletext\begin{isapar}\justifying\color{blue}}{\end{isapar}} +\renewcommand\labelitemi{$*$} +%\urlstyle{rm} + +\begin{document} + +\title{Relational Disjoint-Set Forests} +\author{Walter Guttmann} +\maketitle + +\begin{abstract} + We give a simple relation-algebraic semantics of read and write operations on associative arrays. + The array operations seamlessly integrate with assignments in the Hoare-logic library. + Using relation algebras and Kleene algebras we verify the correctness of an array-based implementation of disjoint-set forests with a naive union operation and a find operation with path compression. +\end{abstract} + +\tableofcontents + +\section{Overview} + +Relation algebras and Kleene algebras have previously been used to reason about graphs and graph algorithms \cite{BackhouseCarre1975,Berghammer1999,BerghammerStruth2010,BerghammerKargerWolf1998,GondranMinoux2008,HoefnerMoeller2012,Moeller1993}. +The operations of these algebras manipulate entire graphs, which is useful for specification but not directly intended for implementation. +Low-level array access is a key ingredient for efficient algorithms \cite{CormenLeisersonRivest1990}. +We give a relation-algebraic semantics for such read/write access to associative arrays. +This allows us to extend relation-algebraic verification methods to a lower level of more efficient implementations. + +In this theory we focus on arrays with the same index and value sets, which can be modelled as homogeneous relations and therefore as elements of relation algebras and Kleene algebras \cite{Kozen1994,Tarski1941}. +We implement and verify the correctness of disjoint-set forests with path compression and naive union \cite{CormenLeisersonRivest1990,GallerFisher1964,Tarjan1975}. + +In order to prepare this theory for future applications with weighted graphs, the verification uses Stone relation algebras, which have weaker axioms than relation algebras \cite{Guttmann2018c}. + +Section 2 contains the simple relation-algebraic semantics of associative array read and write and basic properties of these access operations. +In Section 3 we give a Kleene-relation-algebraic semantics of disjoint-set forests. +The make-set, find-set and union-sets operations are implemented and verified in Section 4. + +This Isabelle/HOL theory formally verifies results in \cite{Guttmann2020b}. +Theorem numbers from this paper are mentioned in the theory for reference. +See the paper for further details and related work. + +Several Isabelle/HOL theories are related to disjoint sets. +The theory \texttt{HOL/Library/Disjoint\_Sets.thy} contains results about partitions and sets of disjoint sets and does not consider their implementation. +An implementation of disjoint-set forests with path compression and a size-based heuristic in the Imperative/HOL framework is verified in Archive of Formal Proofs entry \cite{LammichMeis2012}. +Improved automation of this proof is considered in Archive of Formal Proofs entry \cite{Zhan2018}. +These approaches are based on logical specifications whereas the present theory uses relation algebras and Kleene algebras. + +\begin{flushleft} +\input{session} +\end{flushleft} + +\bibliographystyle{abbrv} +\bibliography{root} + +\end{document} + diff --git a/thys/Relational_Paths/More_Relation_Algebra.thy b/thys/Relational_Paths/More_Relation_Algebra.thy new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/More_Relation_Algebra.thy @@ -0,0 +1,1130 @@ +(* Title: (More) Relation Algebra + Author: Walter Guttmann, Peter Hoefner + Maintainer: Walter Guttmann + Peter Hoefner +*) + +section \(More) Relation Algebra\ + +text \ +This theory presents fundamental properties of relation algebras, which are not present in the AFP entry on relation algebras but could be integrated there \cite{ArmstrongFosterStruthWeber2014}. +Many theorems concern vectors and points. +\ + +theory More_Relation_Algebra + +imports Relation_Algebra.Relation_Algebra_RTC Relation_Algebra.Relation_Algebra_Functions + +begin + +no_notation + trancl ("(_\<^sup>+)" [1000] 999) + +context relation_algebra +begin + +notation + converse ("(_\<^sup>T)" [102] 101) + +abbreviation bijective + where "bijective x \ is_inj x \ is_sur x" + +abbreviation reflexive + where "reflexive R \ 1' \ R" + +abbreviation symmetric + where "symmetric R \ R = R\<^sup>T" + +abbreviation transitive + where "transitive R \ R;R \ R" + +text \General theorems\ + +lemma x_leq_triple_x: + "x \ x;x\<^sup>T;x" +proof - + have "x = x;1' \ 1" + by simp + also have "... \ (x \ 1;1'\<^sup>T);(1' \ x\<^sup>T;1)" + by (rule dedekind) + also have "... = x;(x\<^sup>T;1 \ 1')" + by (simp add: inf.commute) + also have "... \ x;(x\<^sup>T \ 1';1\<^sup>T);(1 \ (x\<^sup>T)\<^sup>T;1')" + by (metis comp_assoc dedekind mult_isol) + also have "... \ x;x\<^sup>T;x" + by simp + finally show ?thesis . +qed + +lemma inj_triple: + assumes "is_inj x" + shows "x = x;x\<^sup>T;x" +by (metis assms eq_iff inf_absorb2 is_inj_def mult_1_left mult_subdistr x_leq_triple_x) + +lemma p_fun_triple: + assumes "is_p_fun x" + shows "x = x;x\<^sup>T;x" +by (metis assms comp_assoc eq_iff is_p_fun_def mult_isol mult_oner x_leq_triple_x) + +lemma loop_backward_forward: + "x\<^sup>T \ -(1') + x" +by (metis conv_e conv_times inf.cobounded2 test_dom test_domain test_eq_conv galois_2 inf.commute + sup.commute) + +lemma inj_sur_semi_swap: + assumes "is_sur z" + and "is_inj x" + shows "z \ y;x \ x \ y\<^sup>T;z" +proof - + assume "z \ y;x" + hence "z;x\<^sup>T \ y;(x;x\<^sup>T)" + by (metis mult_isor mult_assoc) + hence "z;x\<^sup>T \ y" + using \is_inj x\ unfolding is_inj_def + by (metis mult_isol order.trans mult_1_right) + hence "(z\<^sup>T;z);x\<^sup>T \ z\<^sup>T;y" + by (metis mult_isol mult_assoc) + hence "x\<^sup>T \ z\<^sup>T;y" + using \is_sur z\ unfolding is_sur_def + by (metis mult_isor order.trans mult_1_left) + thus ?thesis + using conv_iso by fastforce +qed + +lemma inj_sur_semi_swap_short: + assumes "is_sur z" + and "is_inj x" + shows "z \ y\<^sup>T;x \ x \ y;z" +proof - + assume as: "z \ y\<^sup>T;x" + hence "z;x\<^sup>T \ y\<^sup>T" + using \z \ y\<^sup>T;x\ \is_inj x\ unfolding is_inj_def + by (metis assms(2) conv_invol inf.orderI inf_absorb1 inj_p_fun ss_422iii) + hence "x\<^sup>T \ z\<^sup>T;y\<^sup>T" + using \is_sur z\ unfolding is_sur_def + by (metis as assms inj_sur_semi_swap conv_contrav conv_invol conv_iso) + thus "x \ y;z" + using conv_iso by fastforce +qed + +lemma bij_swap: + assumes "bijective z" + and "bijective x" + shows "z \ y\<^sup>T;x \ x \ y;z" +by (metis assms inj_sur_semi_swap conv_invol) + +text \The following result is \cite[Proposition 4.2.2(iv)]{SchmidtStroehlein1993}.\ + +lemma ss422iv: + assumes "is_p_fun y" + and "x \ y" + and "y;1 \ x;1" + shows "x = y" +proof - + have "y \ (x;1)\y" + using assms(3) le_infI maddux_20 order_trans by blast + also have "... \ x;x\<^sup>T;y" + by (metis inf_top_left modular_1_var comp_assoc) + also have "... \ x;y\<^sup>T;y" + using assms(2) conv_iso mult_double_iso by blast + also have "... \ x" + using assms(1) comp_assoc is_p_fun_def mult_isol mult_1_right + by fastforce + finally show ?thesis + by (simp add: assms(2) antisym) +qed + +text \The following results are variants of \cite[Proposition 4.2.3]{SchmidtStroehlein1993}.\ + +lemma ss423conv: + assumes "bijective x" + shows "x ; y \ z \ y \ x\<^sup>T ; z" +by (metis assms conv_contrav conv_iso inj_p_fun is_map_def ss423 sur_total) + +lemma ss423bij: + assumes "bijective x" + shows "y ; x\<^sup>T \ z \ y \ z ; x" +by (simp add: assms is_map_def p_fun_inj ss423 total_sur) + +lemma inj_distr: + assumes "is_inj z" + shows "(x\y);z = (x;z)\(y;z)" +apply (rule antisym) + using mult_subdistr_var apply blast +using assms conv_iso inj_p_fun p_fun_distl by fastforce + +lemma test_converse: + "x \ 1' = x\<^sup>T \ 1'" +by (metis conv_e conv_times inf_le2 is_test_def test_eq_conv) + +lemma injective_down_closed: + assumes "is_inj x" + and "y \ x" + shows "is_inj y" +by (meson assms conv_iso dual_order.trans is_inj_def mult_isol_var) + +lemma injective_sup: + assumes "is_inj t" + and "e;t\<^sup>T \ 1'" + and "is_inj e" + shows "is_inj (t + e)" +proof - + have 1: "t;e\<^sup>T \ 1'" + using assms(2) conv_contrav conv_e conv_invol conv_iso by fastforce + have "(t + e);(t + e)\<^sup>T = t;t\<^sup>T + t;e\<^sup>T + e;t\<^sup>T + e;e\<^sup>T" + by (metis conv_add distrib_left distrib_right' sup_assoc) + also have "... \ 1'" + using 1 assms by (simp add: is_inj_def le_supI) + finally show ?thesis + unfolding is_inj_def . +qed + +text \Some (more) results about vectors\ + +lemma vector_meet_comp: + assumes "is_vector v" + and "is_vector w" + shows "v;w\<^sup>T = v\w\<^sup>T" +by (metis assms conv_contrav conv_one inf_top_right is_vector_def vector_1) + +lemma vector_meet_comp': + assumes "is_vector v" + shows "v;v\<^sup>T = v\v\<^sup>T" +using assms vector_meet_comp by blast + +lemma vector_meet_comp_x: + "x;1;x\<^sup>T = x;1\1;x\<^sup>T" +by (metis comp_assoc inf_top.right_neutral is_vector_def one_idem_mult vector_1) + +lemma vector_meet_comp_x': + "x;1;x = x;1\1;x" +by (metis inf_commute inf_top.right_neutral ra_1) + +lemma vector_prop1: + assumes "is_vector v" + shows "-v\<^sup>T;v = 0" +by (metis assms compl_inf_bot inf_top.right_neutral one_compl one_idem_mult vector_2) + +text \The following results and a number of others in this theory are from \cite{Guttmann2017a}.\ + +lemma ee: + assumes "is_vector v" + and "e \ v;-v\<^sup>T" + shows "e;e = 0" +proof - + have "e;v \ 0" + by (metis assms annir mult_isor vector_prop1 comp_assoc) + thus ?thesis + by (metis assms(2) annil antisym bot_least comp_assoc mult_isol) +qed + +lemma et: + assumes "is_vector v" + and "e \ v;-v\<^sup>T" + and "t \ v;v\<^sup>T" + shows "e;t = 0" + and "e;t\<^sup>T = 0" +proof - + have "e;t \ v;-v\<^sup>T;v;v\<^sup>T" + by (metis assms(2-3) mult_isol_var comp_assoc) + thus "e;t = 0" + by (simp add: assms(1) comp_assoc le_bot vector_prop1) +next + have "t\<^sup>T \ v;v\<^sup>T" + using assms(3) conv_iso by fastforce + hence "e;t\<^sup>T \ v;-v\<^sup>T;v;v\<^sup>T" + by (metis assms(2) mult_isol_var comp_assoc) + thus "e;t\<^sup>T = 0" + by (simp add: assms(1) comp_assoc le_bot vector_prop1) +qed + +text \Some (more) results about points\ + +definition point + where "point x \ is_vector x \ bijective x" + +lemma point_swap: + assumes "point p" + and "point q" + shows "p \ x;q \ q \ x\<^sup>T;p" +by (metis assms conv_invol inj_sur_semi_swap point_def) + +text \Some (more) results about singletons\ + +abbreviation singleton + where "singleton x \ bijective (x;1) \ bijective (x\<^sup>T;1)" + +lemma singleton_injective: + assumes "singleton x" + shows "is_inj x" +using assms injective_down_closed maddux_20 by blast + +lemma injective_inv: + assumes "is_vector v" + and "singleton e" + and "e \ v;-v\<^sup>T" + and "t \ v;v\<^sup>T" + and "is_inj t" + shows "is_inj (t + e)" +by (metis assms singleton_injective injective_sup bot_least et(2)) + +lemma singleton_is_point: + assumes "singleton p" + shows "point (p;1)" +by (simp add: assms comp_assoc is_vector_def point_def) + +lemma singleton_transp: + assumes "singleton p" + shows "singleton (p\<^sup>T)" +by (simp add: assms) + +lemma point_to_singleton: + assumes "singleton p" + shows "singleton (1'\p;p\<^sup>T)" +using assms dom_def_aux_var dom_one is_vector_def point_def by fastforce + +lemma singleton_singletonT: + assumes "singleton p" + shows "p;p\<^sup>T \ 1'" +using assms singleton_injective is_inj_def by blast + +text \Minimality\ + +abbreviation minimum + where "minimum x v \ v \ -(x\<^sup>T;v)" + +text \Regressively finite\ + +abbreviation regressively_finite + where "regressively_finite x \ \v . is_vector v \ v \ x\<^sup>T;v \ v = 0" + +lemma regressively_finite_minimum: + "regressively_finite R \ is_vector v \ v \ 0 \ minimum R v \ 0" +using galois_aux2 by blast + +lemma regressively_finite_irreflexive: + assumes "regressively_finite x" + shows "x \ -1'" +proof - + have 1: "is_vector ((x\<^sup>T \ 1');1)" + by (simp add: is_vector_def mult_assoc) + have "(x\<^sup>T \ 1');1 = (x\<^sup>T \ 1');(x\<^sup>T \ 1');1" + by (simp add: is_test_def test_comp_eq_mult) + with 1 have "(x\<^sup>T \ 1');1 = 0" + by (metis assms comp_assoc mult_subdistr) + thus ?thesis + by (metis conv_e conv_invol conv_times conv_zero galois_aux ss_p18) +qed + +end (* relation_algebra *) + +subsection \Relation algebras satisfying the Tarski rule\ + +class relation_algebra_tarski = relation_algebra + + assumes tarski: "x \ 0 \ 1;x;1 = 1" +begin + +text \Some (more) results about points\ + +lemma point_equations: + assumes "is_point p" + shows "p;1=p" + and "1;p=1" + and "p\<^sup>T;1=1" + and "1;p\<^sup>T=p\<^sup>T" + apply (metis assms is_point_def is_vector_def) + using assms is_point_def is_vector_def tarski vector_comp apply fastforce + apply (metis assms conv_contrav conv_one conv_zero is_point_def is_vector_def tarski) +by (metis assms conv_contrav conv_one is_point_def is_vector_def) + +text \The following result is \cite[Proposition 2.4.5(i)]{SchmidtStroehlein1993}.\ + +lemma point_singleton: + assumes "is_point p" + and "is_vector v" + and "v \ 0" + and "v \ p" + shows "v = p" +proof - + have "1;v = 1" + using assms(2,3) comp_assoc is_vector_def tarski by fastforce + hence "p = 1;v \ p" + by simp + also have "... \ (1 \ p;v\<^sup>T);(v \ 1\<^sup>T;p)" + using dedekind by blast + also have "... \ p;v\<^sup>T;v" + by (simp add: mult_subdistl) + also have "... \ p;p\<^sup>T;v" + using assms(4) conv_iso mult_double_iso by blast + also have "... \ v" + by (metis assms(1) is_inj_def is_point_def mult_isor mult_onel) + finally show ?thesis + using assms(4) by simp +qed + +lemma point_not_equal_aux: + assumes "is_point p" + and "is_point q" + shows "p\q \ p \ -q \ 0" +proof + show "p \ q \ p \ - q \ 0" + proof (rule contrapos_nn) + assume "p \ -q = 0" + thus "p = q" + using assms galois_aux2 is_point_def point_singleton by fastforce + qed +next + show "p \ - q \ 0 \ p \ q" + using inf_compl_bot by blast +qed + +text \The following result is part of \cite[Proposition 2.4.5(ii)]{SchmidtStroehlein1993}.\ + +lemma point_not_equal: + assumes "is_point p" + and "is_point q" + shows "p\q \ p\-q" + and "p\-q \ p;q\<^sup>T \ -1'" + and "p;q\<^sup>T \ -1' \ p\<^sup>T;q \ 0" +proof - + have "p \ q \ p \ - q" + by (metis assms point_not_equal_aux is_point_def vector_compl vector_mult point_singleton + inf.orderI inf.cobounded1) + thus "p\q \ p\-q" + by (metis assms(1) galois_aux inf.orderE is_point_def order.refl) +next + show "(p \ - q) = (p ; q\<^sup>T \ - 1')" + by (simp add: conv_galois_2) +next + show "(p ; q\<^sup>T \ - 1') = (p\<^sup>T ; q \ 0)" + by (metis assms(2) compl_bot_eq conv_galois_2 galois_aux maddux_141 mult_1_right + point_equations(4)) +qed + +lemma point_is_point: + "point x \ is_point x" +apply (rule iffI) + apply (simp add: is_point_def point_def surj_one tarski) +using is_point_def is_vector_def mult_assoc point_def sur_def_var1 tarski by fastforce + +lemma point_in_vector_or_complement: + assumes "point p" + and "is_vector v" + shows "p \ v \ p \ -v" +proof (cases "p \ -v") + assume "p \ -v" + thus ?thesis + by simp +next + assume "\(p \ -v)" + hence "p\v \ 0" + by (simp add: galois_aux) + hence "1;(p\v) = 1" + using assms comp_assoc is_vector_def point_def tarski vector_mult by fastforce + hence "p \ p;(p\v)\<^sup>T;(p\v)" + by (metis inf_top.left_neutral modular_2_var) + also have "... \ p;p\<^sup>T;v" + by (simp add: mult_isol_var) + also have "... \ v" + using assms(1) comp_assoc point_def ss423conv by fastforce + finally show ?thesis .. +qed + +lemma point_in_vector_or_complement_iff: + assumes "point p" + and "is_vector v" + shows "p \ v \ \(p \ -v)" +by (metis assms annir compl_top_eq galois_aux inf.orderE one_compl point_def ss423conv tarski + top_greatest point_in_vector_or_complement) + +lemma different_points_consequences: + assumes "point p" + and "point q" + and "p\q" + shows "p\<^sup>T;-q=1" + and "-q\<^sup>T;p=1" + and "-(p\<^sup>T;-q)=0" + and "-(-q\<^sup>T;p)=0" +proof - + have "p \ -q" + by (metis assms compl_le_swap1 inf.absorb1 inf.absorb2 point_def point_in_vector_or_complement) + thus 1: "p\<^sup>T;-q=1" + using assms(1) by (metis is_vector_def point_def ss423conv top_le) + thus 2: "-q\<^sup>T;p=1" + using conv_compl conv_one by force + from 1 show "-(p\<^sup>T;-q)=0" + by simp + from 2 show "-(-q\<^sup>T;p)=0" + by simp +qed + +text \Some (more) results about singletons\ + +lemma singleton_pq: + assumes "point p" + and "point q" + shows "singleton (p;q\<^sup>T)" +using assms comp_assoc point_def point_equations(1,3) point_is_point by fastforce + +lemma singleton_equal_aux: + assumes "singleton p" + and "singleton q" + and "q\p" + shows "p \ q;1" +proof - + have pLp: "p;1;p\<^sup>T \1'" + by (simp add: assms(1) maddux_21 ss423conv) + + have "p = 1;(q\<^sup>T;q;1) \ p" + using tarski + by (metis assms(2) annir singleton_injective inf.commute inf_top.right_neutral inj_triple + mult_assoc surj_one) + also have "... \ (1 \ p;(q\<^sup>T;q;1)\<^sup>T);(q\<^sup>T;q;1 \ 1;p)" + using dedekind by (metis conv_one) + also have "... \ p;1;q\<^sup>T;q;q\<^sup>T;q;1" + by (simp add: comp_assoc mult_isol) + also have "... \ p;1;p\<^sup>T;q;q\<^sup>T;q;1" + using assms(3) by (metis comp_assoc conv_iso mult_double_iso) + also have "... \ 1';q;q\<^sup>T;q;1" + using pLp using mult_isor by blast + also have "... \ q;1" + using assms(2) singleton_singletonT by (simp add: comp_assoc mult_isol) + finally show ?thesis . +qed + +lemma singleton_equal: + assumes "singleton p" + and "singleton q" + and "q\p" + shows "q=p" +proof - + have p1: "p \ q;1" + using assms by (rule singleton_equal_aux) + have "p\<^sup>T \ q\<^sup>T;1" + using assms singleton_equal_aux singleton_transp conv_iso by fastforce + hence p2: "p \ 1;q" + using conv_iso by force + + have "p \ q;1 \ 1;q" + using p1 p2 inf.boundedI by blast + also have "... \ (q \ 1;q;1);(1 \ q\<^sup>T;1;q)" + using dedekind by (metis comp_assoc conv_one) + also have "... \ q;q\<^sup>T;1;q" + by (simp add: mult_isor comp_assoc) + also have "... \ q;1'" + by (metis assms(2) conv_contrav conv_invol conv_one is_inj_def mult_assoc mult_isol + one_idem_mult) + also have "... \ q" + by simp + finally have "p \ q" . + thus "q=p" + using assms(3) by simp +qed + +lemma singleton_nonsplit: + assumes "singleton p" + and "x\p" + shows "x=0 \ x=p" +proof (cases "x=0") + assume "x=0" + thus ?thesis .. +next + assume 1: "x\0" + have "singleton x" + proof (safe) + show "is_inj (x;1)" + using assms injective_down_closed mult_isor by blast + show "is_inj (x\<^sup>T;1)" + using assms conv_iso injective_down_closed mult_isol_var by blast + show "is_sur (x;1)" + using 1 comp_assoc sur_def_var1 tarski by fastforce + thus "is_sur (x\<^sup>T;1)" + by (metis conv_contrav conv_one mult.semigroup_axioms sur_def_var1 semigroup.assoc) + qed + thus ?thesis + using assms singleton_equal by blast +qed + +lemma singleton_nonzero: + assumes "singleton p" + shows "p\0" +proof + assume "p = 0" + hence "point 0" + using assms singleton_is_point by fastforce + thus False + by (simp add: is_point_def point_is_point) +qed + +lemma singleton_sum: + assumes "singleton p" + shows "p \ x+y \ (p\x \ p\y)" +proof + show "p \ x + y \ p \ x \ p \ y" + proof - + assume as: "p \ x + y" + show "p \ x \ p \ y" + proof (cases "p\x") + assume "p\x" + thus ?thesis .. + next + assume a:"\(p\x)" + hence "p\x \ p" + using a inf.orderI by fastforce + hence "p \ -x" + using assms singleton_nonsplit galois_aux inf_le1 by blast + hence "p\y" + using as by (metis galois_1 inf.orderE) + thus ?thesis + by simp + qed + qed +next + show "p \ x \ p \ y \ p \ x + y" + using sup.coboundedI1 sup.coboundedI2 by blast +qed + +lemma singleton_iff: + "singleton x \ x \ 0 \ x\<^sup>T;1;x + x;1;x\<^sup>T \ 1'" +by (smt comp_assoc conv_contrav conv_invol conv_one is_inj_def le_sup_iff one_idem_mult + sur_def_var1 tarski) + +lemma singleton_not_atom_in_relation_algebra_tarski: + assumes "p\0" + and "\x . x\p \ x=0 \ x=p" + shows "singleton p" +nitpick [expect=genuine] oops + +end (* relation_algebra_tarski *) + +subsection \Relation algebras satisfying the point axiom\ + +class relation_algebra_point = relation_algebra + + assumes point_axiom: "x \ 0 \ (\y z . point y \ point z \ y;z\<^sup>T \ x)" +begin + +text \Some (more) results about points\ + +lemma point_exists: + "\x . point x" +by (metis (full_types) eq_iff is_inj_def is_sur_def is_vector_def point_axiom point_def) + +lemma point_below_vector: + assumes "is_vector v" + and "v \ 0" + shows "\x . point x \ x \ v" +proof - + from assms(2) obtain y and z where 1: "point y \ point z \ y;z\<^sup>T \ v" + using point_axiom by blast + have "z\<^sup>T;1 = (1;z)\<^sup>T" + using conv_contrav conv_one by simp + hence "y;(1;z)\<^sup>T \ v" + using 1 by (metis assms(1) comp_assoc is_vector_def mult_isor) + thus ?thesis + using 1 by (metis conv_one is_vector_def point_def sur_def_var1) +qed + +end (* relation_algebra_point *) + +class relation_algebra_tarski_point = relation_algebra_tarski + relation_algebra_point +begin + +lemma atom_is_singleton: + assumes "p\0" + and "\x . x\p \ x=0 \ x=p" + shows "singleton p" +by (metis assms singleton_nonzero singleton_pq point_axiom) + +lemma singleton_iff_atom: + "singleton p \ p\0 \ (\x . x\p \ x=0 \ x=p)" +using singleton_nonsplit singleton_nonzero atom_is_singleton by blast + +lemma maddux_tarski: + assumes "x\0" + shows "\y . y\0 \ y\x \ is_p_fun y" +proof - + obtain p q where 1: "point p \ point q \ p;q\<^sup>T \ x" + using assms point_axiom by blast + hence 2: "p;q\<^sup>T\0" + by (simp add: singleton_nonzero singleton_pq) + have "is_p_fun (p;q\<^sup>T)" + using 1 by (meson singleton_singletonT singleton_pq singleton_transp is_inj_def p_fun_inj) + thus ?thesis + using 1 2 by force +qed + +text \Intermediate Point Theorem \cite[Proposition 2.4.8]{SchmidtStroehlein1993}\ + +lemma intermediate_point_theorem: + assumes "point p" + and "point r" + shows "p \ x;y;r \ (\q . point q \ p \ x;q \ q \ y;r)" +proof + assume 1: "p \ x;y;r" + let ?v = "x\<^sup>T;p \ y;r" + have 2: "is_vector ?v" + using assms comp_assoc is_vector_def point_def vector_mult by fastforce + have "?v \ 0" + using 1 by (metis assms(1) inf.absorb2 is_point_def maddux_141 point_is_point mult.assoc) + hence "\q . point q \ q \ ?v" + using 2 point_below_vector by blast + thus "\q . point q \ p \ x;q \ q \ y;r" + using assms(1) point_swap by auto +next + assume "\q . point q \ p \ x;q \ q \ y;r" + thus "p \ x;y;r" + using comp_assoc mult_isol order_trans by fastforce +qed + +end (* relation_algebra_tarski_point *) + +(* +The following shows that rtc can be defined with only 2 axioms. +This should eventually go into AFP/Relation_Algebra_RTC.relation_algebra_rtc. +There the class definition should be replaced with: + +class relation_algebra_rtc = relation_algebra + star_op + + assumes rtc_unfoldl: "1' + x ; x\<^sup>\ \ x\<^sup>\" + and rtc_inductl: "z + x ; y \ y \ x\<^sup>\ ; z \ y" + +and the following lemmas: +*) + +context relation_algebra +begin + +lemma unfoldl_inductl_implies_unfoldr: + assumes "\x. 1' + x;(rtc x) \ rtc x" + and "\x y z. x+y;z \ z \ rtc(y);x \ z" + shows "1' + rtc(x);x \ rtc x" +by (metis assms le_sup_iff mult_oner order.trans subdistl_eq sup_absorb2 sup_ge1) + +lemma star_transpose_swap: + assumes "\x. 1' + x;(rtc x) \ rtc x" + and "\x y z. x+y;z \ z \ rtc(y);x \ z" + shows "rtc(x\<^sup>T) = (rtc x)\<^sup>T" +apply(simp only: eq_iff; rule conjI) + apply (metis assms conv_add conv_contrav conv_e conv_iso mult_1_right + unfoldl_inductl_implies_unfoldr ) +by (metis assms conv_add conv_contrav conv_e conv_invol conv_iso mult_1_right + unfoldl_inductl_implies_unfoldr) + +lemma unfoldl_inductl_implies_inductr: + assumes "\x. 1' + x;(rtc x) \ rtc x" + and "\x y z. x+y;z \ z \ rtc(y);x \ z" + shows "x+z;y \ z \ x;rtc(y) \ z" +by (metis assms conv_add conv_contrav conv_iso star_transpose_swap) + +end (* relation_algebra *) + +context relation_algebra_rtc +begin + +abbreviation tc ("(_\<^sup>+)" [101] 100) where "tc x \ x;x\<^sup>\" + +abbreviation is_acyclic + where "is_acyclic x \ x\<^sup>+ \ -1'" + +text \General theorems\ + +lemma star_denest_10: + assumes "x;y=0" + shows "(x+y)\<^sup>\ = y;y\<^sup>\;x\<^sup>\+x\<^sup>\" +using assms bubble_sort sup.commute by auto + +lemma star_star_plus: + "x\<^sup>\ + y\<^sup>\ = x\<^sup>+ + y\<^sup>\" +by (metis (full_types) sup.left_commute star_plus_one star_unfoldl_eq sup.commute) + +text \The following two lemmas are from \cite{Guttmann2018b}.\ + +lemma cancel_separate: + assumes "x ; y \ 1'" + shows "x\<^sup>\ ; y\<^sup>\ \ x\<^sup>\ + y\<^sup>\" +proof - + have "x ; y\<^sup>\ = x + x ; y ; y\<^sup>\" + by (metis comp_assoc conway.dagger_unfoldl_distr distrib_left mult_oner) + also have "... \ x + y\<^sup>\" + by (metis assms join_isol star_invol star_plus_one star_subdist_var_2 sup.absorb2 sup.assoc) + also have "... \ x\<^sup>\ + y\<^sup>\" + using join_iso by fastforce + finally have "x ; (x\<^sup>\ + y\<^sup>\) \ x\<^sup>\ + y\<^sup>\" + by (simp add: distrib_left le_supI1) + thus ?thesis + by (simp add: rtc_inductl) +qed + +lemma cancel_separate_inj_converse: + assumes "is_inj x" + shows "x\<^sup>\ ; x\<^sup>T\<^sup>\ = x\<^sup>\ + x\<^sup>T\<^sup>\" + apply (rule antisym) + using assms cancel_separate is_inj_def apply blast +by (metis conway.dagger_unfoldl_distr le_supI mult_1_right mult_isol sup.cobounded1) + +lemma cancel_separate_p_fun_converse: + assumes "is_p_fun x" + shows "x\<^sup>T\<^sup>\ ; x\<^sup>\ = x\<^sup>\ + x\<^sup>T\<^sup>\" +using sup_commute assms cancel_separate_inj_converse p_fun_inj by fastforce + +lemma cancel_separate_converse_idempotent: + assumes "is_inj x" + and "is_p_fun x" + shows "(x\<^sup>\ + x\<^sup>T\<^sup>\);(x\<^sup>\ + x\<^sup>T\<^sup>\) = x\<^sup>\ + x\<^sup>T\<^sup>\" +by (metis assms cancel_separate cancel_separate_p_fun_converse church_rosser_equiv is_inj_def + star_denest_var_6) + +lemma triple_star: + assumes "is_inj x" + and "is_p_fun x" + shows "x\<^sup>\;x\<^sup>T\<^sup>\;x\<^sup>\ = x\<^sup>\ + x\<^sup>T\<^sup>\" +by (simp add: assms cancel_separate_inj_converse cancel_separate_p_fun_converse) + +lemma inj_xxts: + assumes "is_inj x" + shows "x;x\<^sup>T\<^sup>\ \ x\<^sup>\ + x\<^sup>T\<^sup>\" +by (metis assms cancel_separate_inj_converse distrib_right less_eq_def star_ext) + +lemma plus_top: + "x\<^sup>+;1 = x;1" +by (metis comp_assoc conway.dagger_unfoldr_distr sup_top_left) + +lemma top_plus: + "1;x\<^sup>+ = 1;x" +by (metis comp_assoc conway.dagger_unfoldr_distr star_denest_var_2 star_ext star_slide_var + sup_top_left top_unique) + +lemma plus_conv: + "(x\<^sup>+)\<^sup>T = x\<^sup>T\<^sup>+" +by (simp add: star_conv star_slide_var) + +lemma inj_implies_step_forwards_backwards: + assumes "is_inj x" + shows "x\<^sup>\;(x\<^sup>+\1');1 \ x\<^sup>T;1" +proof - + have "(x\<^sup>+\1');1 \ (x\<^sup>\\x\<^sup>T);(x\(x\<^sup>\)\<^sup>T);1" + by (metis conv_contrav conv_e dedekind mult_1_right mult_isor star_slide_var) + also have "... \ (x\<^sup>\\x\<^sup>T);1" + by (simp add: comp_assoc mult_isol) + finally have 1: "(x\<^sup>+\1');1 \ (x\<^sup>\\x\<^sup>T);1" . + + have "x;(x\<^sup>\\x\<^sup>T);1 \ (x\<^sup>+\x;x\<^sup>T);1" + by (metis inf_idem meet_interchange mult_isor) + also have "... \ (x\<^sup>+\1');1" + using assms is_inj_def meet_isor mult_isor by fastforce + finally have "x;(x\<^sup>\\x\<^sup>T);1 \ (x\<^sup>\\x\<^sup>T);1" + using 1 by fastforce + hence "x\<^sup>\;(x\<^sup>+\1');1 \ (x\<^sup>\\x\<^sup>T);1" + using 1 by (simp add: comp_assoc rtc_inductl) + thus "x\<^sup>\;(x\<^sup>+\1');1 \ x\<^sup>T;1" + using inf.cobounded2 mult_isor order_trans by blast +qed + +text \Acyclic relations\ + +text \The following result is from \cite{Guttmann2017c}.\ + +lemma acyclic_inv: + assumes "is_acyclic t" + and "is_vector v" + and "e \ v;-v\<^sup>T" + and "t \ v;v\<^sup>T" + shows "is_acyclic (t + e)" +proof - + have "t\<^sup>+;e \ t\<^sup>+;v;-v\<^sup>T" + by (simp add: assms(3) mult_assoc mult_isol) + also have "... \ v;v\<^sup>T;t\<^sup>\;v;-v\<^sup>T" + by (simp add: assms(4) mult_isor) + also have "... \ v;-v\<^sup>T" + by (metis assms(2) mult_double_iso top_greatest is_vector_def mult_assoc) + also have "... \ -1'" + by (simp add: conv_galois_1) + finally have 1: "t\<^sup>+;e \ -1'" . + have "e \ v;-v\<^sup>T" + using assms(3) by simp + also have "... \ -1'" + by (simp add: conv_galois_1) + finally have 2: "t\<^sup>+;e + e \ -1'" + using 1 by simp + have 3: "e;t\<^sup>\ = e" + by (metis assms(2-4) et(1) independence2) + have 4: "e\<^sup>\ = 1' + e" + using assms(2-3) ee boffa_var bot_least by blast + have "(t + e)\<^sup>+ = (t + e);t\<^sup>\;(e;t\<^sup>\)\<^sup>\" + by (simp add: comp_assoc) + also have "... = (t + e);t\<^sup>\;(1' + e)" + using 3 4 by simp + also have "... = t\<^sup>+;(1' + e) + e;t\<^sup>\;(1' + e)" + by simp + also have "... = t\<^sup>+;(1' + e) + e;(1' + e)" + using 3 by simp + also have "... = t\<^sup>+;(1' + e) + e" + using 4 assms(2-3) ee independence2 by fastforce + also have "... = t\<^sup>+ + t\<^sup>+;e + e" + by (simp add: distrib_left) + also have "... \ -1'" + using assms(1) 2 by simp + finally show ?thesis . +qed + +lemma acyclic_single_step: + assumes "is_acyclic x" + shows "x \ -1'" +by (metis assms dual_order.trans mult_isol mult_oner star_ref) + +lemma acyclic_reachable_points: + assumes "is_point p" + and "is_point q" + and "p \ x;q" + and "is_acyclic x" + shows "p\q" +proof + assume "p=q" + hence "p \ x;q \ q" + by (simp add: assms(3) eq_iff inf.absorb2) + also have "... = (x \ 1');q" + using assms(2) inj_distr is_point_def by simp + also have "... \ (-1' \ 1');q" + using acyclic_single_step assms(4) by (metis abel_semigroup.commute inf.abel_semigroup_axioms + meet_isor mult_isor) + also have "... = 0" + by simp + finally have "p \ 0" . + thus False + using assms(1) bot_unique is_point_def by blast +qed + +lemma acyclic_trans: + assumes "is_acyclic x" + shows "x \ -(x\<^sup>T\<^sup>+)" +proof - + have "\c\x. c \ - (x\<^sup>+)\<^sup>T" + by (metis assms compl_mono conv_galois_2 conv_iso double_compl mult_onel star_1l) + thus ?thesis + by (metis dual_order.trans plus_conv) +qed + +lemma acyclic_trans': + assumes "is_acyclic x" + shows "x\<^sup>\ \ -(x\<^sup>T\<^sup>+)" +proof - + have "x\<^sup>\ \ - (- (- (x\<^sup>T ; - (- 1'))) ; (x\<^sup>\)\<^sup>T)" + by (metis assms conv_galois_1 conv_galois_2 order_trans star_trans) + then show ?thesis + by (simp add: star_conv) +qed + +text \Regressively finite\ + +lemma regressively_finite_acyclic: + assumes "regressively_finite x" + shows "is_acyclic x" +proof - + have 1: "is_vector ((x\<^sup>+ \ 1');1)" + by (simp add: is_vector_def mult_assoc) + have "(x\<^sup>+ \ 1');1 = (x\<^sup>T\<^sup>+ \ 1');1" + by (metis plus_conv test_converse) + also have "... \ x\<^sup>T;(1';x\<^sup>T\<^sup>\ \ x);1" + by (metis conv_invol modular_1_var mult_isor mult_oner mult_onel) + also have "... \ x\<^sup>T;(1' \ x\<^sup>+);x\<^sup>T\<^sup>\;1" + by (metis comp_assoc conv_invol modular_2_var mult_isol mult_isor star_conv) + also have "... = x\<^sup>T;(x\<^sup>+ \ 1');1" + by (metis comp_assoc conway.dagger_unfoldr_distr inf.commute sup.cobounded1 top_le) + finally have "(x\<^sup>+ \ 1');1 = 0" + using 1 assms by (simp add: comp_assoc) + thus ?thesis + by (simp add: galois_aux ss_p18) +qed + +notation power (infixr "\" 80) + +lemma power_suc_below_plus: + "x \ Suc n \ x\<^sup>+" + apply (induct n) + using mult_isol star_ref apply fastforce +by (simp add: mult_isol_var order_trans) + +end (* relation_algebra_rtc *) + +class relation_algebra_rtc_tarski = relation_algebra_rtc + relation_algebra_tarski +begin + +lemma point_loop_not_acyclic: + assumes "is_point p" + and "p \ x \ Suc n ; p" + shows "\ is_acyclic x" +proof - + have "p \ x\<^sup>+ ; p" + by (meson assms dual_order.trans point_def point_is_point ss423bij power_suc_below_plus) + hence "p ; p\<^sup>T \ x\<^sup>+" + using assms(1) point_def point_is_point ss423bij by blast + thus ?thesis + using assms(1) order.trans point_not_equal(1) point_not_equal(2) by blast +qed + +end + +class relation_algebra_rtc_point = relation_algebra_rtc + relation_algebra_point + +class relation_algebra_rtc_tarski_point = relation_algebra_rtc_tarski + relation_algebra_rtc_point + + relation_algebra_tarski_point + +text \ +Finite graphs: the axiom says the algebra has finitely many elements. +This means the relations have a finite base set. +\ + +class relation_algebra_rtc_tarski_point_finite = relation_algebra_rtc_tarski_point + finite +begin + +text \For a finite acyclic relation, the powers eventually vanish.\ + +lemma acyclic_power_vanishes: + assumes "is_acyclic x" + shows "\n . x \ Suc n = 0" +proof - + let ?n = "card { p . is_point p }" + let ?p = "x \ ?n" + have "?p = 0" + proof (rule ccontr) + assume "?p \ 0" + from this obtain p q where 1: "point p \ point q \ p;q\<^sup>T \ ?p" + using point_axiom by blast + hence 2: "p \ ?p;q" + using point_def ss423bij by blast + have "\n\?n . (\f. \i\n . is_point (f i) \ (\j\i . p \ x\(?n-i) ; f i \ f i \ x\(i-j) ; f j))" + proof + fix n + show "n\?n \ (\f. \i\n . is_point (f i) \ (\j\i . p \ x\(?n-i) ; f i \ f i \ x\(i-j) ; f j))" + proof (induct n) + case 0 + thus ?case + using 1 2 point_is_point by fastforce + next + case (Suc n) + fix n + assume 3: "n\?n \ (\f . \i\n . is_point (f i) \ (\j\i . p \ x \ (?n-i) ; f i \ f i \ x \ (i-j) ; f j))" + show "Suc n\?n \ (\f . \i\Suc n . is_point (f i) \ (\j\i . p \ x \ (?n-i) ; f i \ f i \ x \ (i-j) ; f j))" + proof + assume 4: "Suc n\?n" + from this obtain f where 5: "\i\n . is_point (f i) \ (\j\i . p \ x \ (?n-i) ; f i \ f i \ x \ (i-j) ; f j)" + using 3 by auto + have "p \ x \ (?n-n) ; f n" + using 5 by blast + also have "... = x \ (?n-n-one_class.one) ; x ; f n" + using 4 by (metis (no_types) Suc_diff_le diff_Suc_1 diff_Suc_Suc power_Suc2) + finally obtain r where 6: "point r \ p \ x \ (?n-Suc n) ; r \ r \ x ; f n" + using 1 5 intermediate_point_theorem point_is_point by fastforce + let ?g = "\m . if m = Suc n then r else f m" + have "\i\Suc n . is_point (?g i) \ (\j\i . p \ x \ (?n-i) ; ?g i \ ?g i \ x \ (i-j) ; ?g j)" + proof + fix i + show "i\Suc n \ is_point (?g i) \ (\j\i . p \ x \ (?n-i) ; ?g i \ ?g i \ x \ (i-j) ; ?g j)" + proof (cases "i\n") + case True + thus ?thesis + using 5 by simp + next + case False + have "is_point (?g (Suc n)) \ (\j\Suc n . p \ x \ (?n-Suc n) ; ?g (Suc n) \ ?g (Suc n) \ x \ (Suc n-j) ; ?g j)" + proof + show "is_point (?g (Suc n))" + using 6 point_is_point by fastforce + next + show "\j\Suc n . p \ x \ (?n-Suc n) ; ?g (Suc n) \ ?g (Suc n) \ x \ (Suc n-j) ; ?g j" + proof + fix j + show "j\Suc n \ p \ x \ (?n-Suc n) ; ?g (Suc n) \ ?g (Suc n) \ x \ (Suc n-j) ; ?g j" + proof + assume 7: "j\Suc n" + show "p \ x \ (?n-Suc n) ; ?g (Suc n) \ ?g (Suc n) \ x \ (Suc n-j) ; ?g j" + proof + show "p \ x \ (?n-Suc n) ; ?g (Suc n)" + using 6 by simp + next + show "?g (Suc n) \ x \ (Suc n-j) ; ?g j" + proof (cases "j = Suc n") + case True + thus ?thesis + by simp + next + case False + hence "f n \ x \ (n-j) ; f j" + using 5 7 by fastforce + hence "x ; f n \ x \ (Suc n-j) ; f j" + using 7 False Suc_diff_le comp_assoc mult_isol by fastforce + thus ?thesis + using 6 False by fastforce + qed + qed + qed + qed + qed + thus ?thesis + by (simp add: False le_Suc_eq) + qed + qed + thus "\f . \i\Suc n . is_point (f i) \ (\j\i . p \ x \ (?n-i) ; f i \ f i \ x \ (i-j) ; f j)" + by auto + qed + qed + qed + from this obtain f where 8: "\i\?n . is_point (f i) \ (\j\i . p \ x \ (?n-i) ; f i \ f i \ x \ (i-j) ; f j)" + by fastforce + let ?A = "{ k . k\?n }" + have "f ` ?A \ { p . is_point p }" + using 8 by blast + hence "card (f ` ?A) \ ?n" + by (simp add: card_mono) + hence "\ inj_on f ?A" + by (simp add: pigeonhole) + from this obtain i j where 9: "i \ ?n \ j \ ?n \ i \ j \ f i = f j" + by (metis (no_types, lifting) inj_on_def mem_Collect_eq) + show False + apply (cases "i < j") + using 8 9 apply (metis Suc_diff_le Suc_leI assms diff_Suc_Suc order_less_imp_le + point_loop_not_acyclic) + using 8 9 by (metis assms neqE point_loop_not_acyclic Suc_diff_le Suc_leI assms diff_Suc_Suc + order_less_imp_le) + qed + thus ?thesis + by (metis annir power.simps(2)) +qed + +text \Hence finite acyclic relations are regressively finite.\ + +lemma acyclic_regressively_finite: + assumes "is_acyclic x" + shows "regressively_finite x" +proof + have "is_acyclic (x\<^sup>T)" + using assms acyclic_trans' compl_le_swap1 order_trans star_ref by blast + from this obtain n where 1: "x\<^sup>T \ Suc n = 0" + using acyclic_power_vanishes by fastforce + fix v + show "is_vector v \ v \ x\<^sup>T;v \ v = 0" + proof + assume 2: "is_vector v \ v \ x\<^sup>T;v" + have "v \ x\<^sup>T \ Suc n ; v" + proof (induct n) + case 0 + thus ?case + using 2 by simp + next + case (Suc n) + hence "x\<^sup>T ; v \ x\<^sup>T \ Suc (Suc n) ; v" + by (simp add: comp_assoc mult_isol) + thus ?case + using 2 dual_order.trans by blast + qed + thus "v = 0" + using 1 by (simp add: le_bot) + qed + qed + +lemma acyclic_is_regressively_finite: + "is_acyclic x \ regressively_finite x" +using acyclic_regressively_finite regressively_finite_acyclic by blast + +end (* end relation_algebra_rtc_tarski_point_finite *) + +end diff --git a/thys/Relational_Paths/Path_Algorithms.thy b/thys/Relational_Paths/Path_Algorithms.thy new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/Path_Algorithms.thy @@ -0,0 +1,995 @@ +(* Title: Correctness of Path Algorithms + Author: Walter Guttmann, Peter Hoefner + Maintainer: Walter Guttmann + Peter Hoefner +*) + +section \Correctness of Path Algorithms\ + +text \ +To show that our theory of paths integrates with verification tasks, we verify the correctness of three basic path algorithms. +Algorithms at the presented level are executable and can serve prototyping purposes. +Data refinement can be carried out to move from such algorithms to more efficient programs. +The total-correctness proofs use a library developed in \cite{Guttmann2018c}. +\ + +theory Path_Algorithms + +imports Aggregation_Algebras.Hoare_Logic Rooted_Paths + +begin + +no_notation + trancl ("(_\<^sup>+)" [1000] 999) + +class choose_singleton_point_signature = + fixes choose_singleton :: "'a \ 'a" + fixes choose_point :: "'a \ 'a" + +class relation_algebra_rtc_tarski_choose_point = + relation_algebra_rtc_tarski + choose_singleton_point_signature + + assumes choose_singleton_singleton: "x \ 0 \ singleton (choose_singleton x)" + assumes choose_singleton_decreasing: "choose_singleton x \ x" + assumes choose_point_point: "is_vector x \ x \ 0 \ point (choose_point x)" + assumes choose_point_decreasing: "choose_point x \ x" +begin + +no_notation + composition (infixl ";" 75) and + times (infixl "*" 70) + +notation + composition (infixl "*" 75) + +subsection \Construction of a path\ + +text \ +Our first example is a basic greedy algorithm that constructs a path from a vertex $x$ to a different vertex $y$ of a directed acyclic graph $D$. +\ + +abbreviation "construct_path_inv q x y D W \ + is_acyclic D \ point x \ point y \ point q \ + D\<^sup>\ * q \ D\<^sup>T\<^sup>\ * x \ W \ D \ terminating_path W \ + (W = 0 \ q=y) \ (W \ 0 \ q = start_points W \ y = end_points W)" + +abbreviation "construct_path_inv_simp q x y D W \ + is_acyclic D \ point x \ point y \ point q \ + D\<^sup>\ * q \ D\<^sup>T\<^sup>\ * x \ W \ D \ terminating_path W \ + q = start_points W \ y = end_points W" + +lemma construct_path_pre: + assumes "is_acyclic D" + and "point y" + and "point x" + and "D\<^sup>\ * y \ D\<^sup>T\<^sup>\ * x" + shows "construct_path_inv y x y D 0" + apply (intro conjI, simp_all add: assms is_inj_def is_p_fun_def path_def) + using assms(2) cycle_iff by fastforce + +text \ +The following three lemmas are auxiliary lemmas for \construct_path_inv\. +They are pulled out of the main proof to have more structure. +\ + +lemma path_inv_points: + assumes "construct_path_inv q x y D W \ q \ x" + shows "point q" + and "point (choose_point (D*q))" + using assms apply blast +by (metis assms choose_point_point comp_assoc is_vector_def point_def reachable_implies_predecessor) + +lemma path_inv_choose_point_decrease: + assumes "construct_path_inv q x y D W \ q \ x" + shows "W\0 \ choose_point (D*q) \ -((W + choose_point (D*q) * q\<^sup>T)\<^sup>T*1)" +proof - + let ?q = "choose_point (D*q)" + let ?W = "W + ?q * q\<^sup>T" + assume as: "W\0" + hence "q*W \ W\<^sup>+" (* "connected_root q W" *) + by (metis assms conv_contrav conv_invol conv_iso conv_terminating_path + forward_terminating_path_end_points_1 plus_conv point_def ss423bij + terminating_path_iff) + hence "?q \ W\<^sup>T*1 \ D*q \ W\<^sup>T\<^sup>+*q" + using choose_point_decreasing meet_iso meet_isor inf_mono assms connected_root_iff2 by simp + also have "... \ (D \ D\<^sup>T\<^sup>+)*q" + by (metis assms inj_distr point_def conv_contrav conv_invol conv_iso meet_isor + mult_isol_var mult_isor star_conv star_slide_var star_subdist sup.commute sup.orderE) + also have "... \ 0" + by (metis acyclic_trans assms conv_zero step_has_target eq_iff galois_aux ss_p18) + finally have a: "?q \ -(W\<^sup>T*1)" + using galois_aux le_bot by blast + + have "point ?q" + using assms by(rule path_inv_points(2)) + hence "?q \ -(q*?q\<^sup>T*1)" + by (metis assms acyclic_imp_one_step_different_points(2) point_is_point + choose_point_decreasing edge_end end_point_char end_point_no_successor) + with a show ?thesis + by (simp add: inf.boundedI) +qed + +lemma end_points: + assumes "construct_path_inv q x y D W \ q \ x" + shows "choose_point (D*q) = start_points (W + choose_point (D*q) * q\<^sup>T)" + and "y = end_points (W + choose_point (D*q) * q\<^sup>T)" +proof - + let ?q = "choose_point (D*q)" + let ?W = "W + ?q * q\<^sup>T" + show 1: "?q = start_points ?W" + proof (rule antisym) + show" start_points ?W \ ?q" + by (metis assms(1) path_inv_points(2) acyclic_imp_one_step_different_points(2) + choose_point_decreasing edge_end edge_start sup.commute + path_concatenation_start_points_approx point_is_point eq_iff sup_bot_left) + show "?q \ start_points ?W" + proof - + have a: "?q = ?q*q\<^sup>T*1" + by (metis assms(1) comp_assoc point_equations(1) point_is_point aux4 conv_zero + choose_point_decreasing choose_point_point conv_contrav conv_one point_def + inf.orderE inf_compl_bot inf_compl_bot_right is_vector_def maddux_142 + sup_bot_left sur_def_var1) + hence "?q =(q \ -q) + (?q \ -q \ -(?W\<^sup>T*1))" + by (metis assms path_inv_points(2) path_inv_choose_point_decrease + acyclic_imp_one_step_different_points(1) choose_point_decreasing inf.orderE + inf_compl_bot sup_inf_absorb edge_start point_is_point sup_bot_left) + also have "... \ (W*1 \ -(?W\<^sup>T*1) \ -q) + (?q \ -q \ -(?W\<^sup>T*1))" + by simp + also have "... = (W*1 + ?q) \ -(q + ?W\<^sup>T*1)" + by (metis compl_sup inf_sup_distrib2 meet_assoc sup.commute) + also have "... \ ?W*1 \ -(?W\<^sup>T*1)" + using a by (metis inf.left_commute distrib_right' compl_sup inf.cobounded2) + finally show "?q \ start_points ?W" . + qed + qed + show "y = end_points ?W" + proof - + have point_nq: "point ?q" + using assms by(rule path_inv_points(2)) + hence yp: "y \ -?q" + using 1 assms + by (metis acyclic_imp_one_step_different_points(2) choose_point_decreasing cycle_no_points(1) + finite_iff finite_iff_msc forward_finite_iff_msc path_aux1a path_edge_equals_cycle + point_is_point point_not_equal(1) terminating_iff1) + have "y = y + (W*1 \ -(W\<^sup>T*1) \ -(W*1))" + by (simp add: inf.commute) + also have "... = y + (q \ -(W*1))" + using assms by fastforce + also have "... = y + (q \ -(W*1) \ -?q)" + by (metis calculation sup_assoc sup_inf_absorb) + also have "... = (y \ -?q) + (q \ -(W*1) \ -?q)" + using yp by (simp add: inf.absorb1) + also have "... = (W\<^sup>T*1 \ -(W*1) \ -?q) + (q \ -(W*1) \ -?q)" + using assms by fastforce + also have "... = (W\<^sup>T*1 + q) \ -(W*1) \ -?q" + by (simp add: inf_sup_distrib2) + also have "... = (W\<^sup>T*1 + q) \ -(W*1 + ?q)" + by (simp add: inf.assoc) + also have "... = (W\<^sup>T*1 + q*?q\<^sup>T*1) \ -(W*1 + ?q*q\<^sup>T*1)" + using point_nq + by(metis assms(1) comp_assoc conv_contrav conv_one is_vector_def point_def sur_def_var1) + also have "... = (?W\<^sup>T)*1 \ -(?W*1)" + by simp + finally show ?thesis . + qed +qed + +lemma construct_path_inv: + assumes "construct_path_inv q x y D W \ q \ x" + shows "construct_path_inv (choose_point (D*q)) x y D (W + choose_point (D*q)*q\<^sup>T)" +proof (intro conjI) + let ?q = "choose_point (D*q)" + let ?W = "W + ?q * q\<^sup>T" + show "is_acyclic D" + using assms by blast + show point_y: "point y" + using assms by blast + show "point x" + using assms by blast + show "?W \ D" + using assms choose_point_decreasing le_sup_iff point_def ss423bij inf.boundedE by blast + show "D\<^sup>\*?q \ D\<^sup>T\<^sup>\*x" + proof - + have "D\<^sup>+*q \ D\<^sup>T\<^sup>\*x" + using assms conv_galois_2 order_trans star_1l by blast + thus ?thesis + by (metis choose_point_decreasing comp_assoc dual_order.trans mult_isol star_slide_var) + qed + show point_nq: "point ?q" + using assms by(rule path_inv_points(2)) + show pathW: "path ?W" + proof(cases "W=0") + assume "W=0" + thus ?thesis + using assms edge_is_path point_is_point point_nq by simp + next + assume a: "W\0" + have b: "?q*q\<^sup>T \ 1*?q*q\<^sup>T*-(?q*q\<^sup>T*1)" + proof - + have "?q*q\<^sup>T \1" by simp + thus ?thesis + using assms point_nq + by(metis different_points_consequences(1) point_def sur_def_var1 + acyclic_imp_one_step_different_points(2) choose_point_decreasing comp_assoc + is_vector_def point_def point_equations(3,4) point_is_point) + qed + have c: "W \ -(1*W)*W*1" + using assms terminating_path_iff by blast + have d: "(?q*q\<^sup>T)\<^sup>T*1 \ -((?q*q\<^sup>T)*1) = W*1 \ -(W\<^sup>T*1)" + using a + by (metis assms path_inv_points(2) acyclic_reachable_points choose_point_decreasing + edge_end point_is_point comp_assoc point_def sur_total total_one) + have e: "?q*q\<^sup>T*1 \ W\<^sup>T*1 = 0" + proof - + have "?q*q\<^sup>T*1 \ W\<^sup>T*1 = ?q \ W\<^sup>T*1" + using assms point_nq + by (metis comp_assoc conv_contrav conv_one is_vector_def point_def sur_def_var1) + also have "... \ -(?W\<^sup>T*1) \ ?W\<^sup>T*1" + using assms path_inv_choose_point_decrease + by (smt a conv_contrav conv_iso conv_one inf_mono less_eq_def subdistl_eq) + also have "... \ 0" + using compl_inf_bot eq_refl by blast + finally show ?thesis + using bot_unique by blast + qed + show ?thesis + using b c d e by (metis assms comp_assoc edge_is_path path_concatenation_cycle_free + point_is_point sup.commute point_nq) + qed + show "?W = 0 \ ?q = y" + apply (rule iffI) + apply (metis assms conv_zero dist_alt edge_start inf_compl_bot_right modular_1_aux' modular_2_aux' + point_is_point sup.left_idem sup_bot_left point_nq) + by (smt assms end_points(1) conv_contrav conv_invol cycle_no_points(1) end_point_iff2 has_start_end_points_iff path_aux1b path_edge_equals_cycle point_is_point start_point_iff2 sup_bot_left top_greatest pathW) + show "?W\0 \ ?q = start_points ?W \ y = end_points ?W" + apply (rule iffI) + using assms end_points apply blast + using assms by force + show "terminating ?W" + by (smt assms end_points end_point_iff2 has_start_end_points_iff point_is_point start_point_iff2 + terminating_iff1 pathW point_nq) +qed + +theorem construct_path_partial: "VARS p q W + { is_acyclic D \ point y \ point x \ D\<^sup>\*y \ D\<^sup>T\<^sup>\*x } + W := 0; + q := y; + WHILE q \ x + INV { construct_path_inv q x y D W } + DO p := choose_point (D*q); + W := W + p*q\<^sup>T; + q := p + OD + { W \ D \ terminating_path W \ (W=0 \ x=y) \ (W\0 \ x = start_points W \ y = end_points W) }" + apply vcg + using construct_path_pre apply blast + using construct_path_inv apply blast + by fastforce + +end (* relation_algebra_rtc_tarski_choose_point *) + +text \For termination, we additionally need finiteness.\ + +context finite +begin + +lemma decrease_set: + assumes "\x::'a . Q x \ P x" + and "P w" + and "\ Q w" + shows "card { x . Q x } < card { x . P x }" +by (metis Collect_mono assms card_seteq finite mem_Collect_eq not_le) + +end + +class relation_algebra_rtc_tarski_choose_point_finite = + relation_algebra_rtc_tarski_choose_point + relation_algebra_rtc_tarski_point_finite +begin + +lemma decrease_variant: + assumes "y \ z" + and "w \ z" + and "\ w \ y" + shows "card { x . x \ y } < card { x . x \ z }" +by (metis Collect_mono assms card_seteq linorder_not_le dual_order.trans finite_code mem_Collect_eq) + +lemma construct_path_inv_termination: + assumes "construct_path_inv q x y D W \ q \ x" + shows "card { z . z \ -(W + choose_point (D*q)*q\<^sup>T) } < card { z . z \ -W }" +proof - + let ?q = "choose_point (D*q)" + let ?W = "W + ?q * q\<^sup>T" + show ?thesis + proof (rule decrease_variant) + show "-?W \ -W" + by simp + show "?q * q\<^sup>T \ -W" + by (metis assms galois_aux inf_compl_bot_right maddux_142 mult_isor order_trans top_greatest) + show "\ (?q * q\<^sup>T \ -?W)" + using assms end_points(1) + by (smt acyclic_imp_one_step_different_points(2) choose_point_decreasing compl_sup inf.absorb1 + inf_compl_bot_right sup.commute sup_bot.left_neutral conv_zero end_points(2)) + qed +qed + +theorem construct_path_total: "VARS p q W + [ is_acyclic D \ point y \ point x \ D\<^sup>\*y \ D\<^sup>T\<^sup>\*x ] + W := 0; + q := y; + WHILE q \ x + INV { construct_path_inv q x y D W } + VAR { card { z . z \ -W } } + DO p := choose_point (D*q); + W := W + p*q\<^sup>T; + q := p + OD + [ W \ D \ terminating_path W \ (W=0 \ x=y) \ (W\0 \ x = start_points W \ y = end_points W) ]" + apply vcg_tc + using construct_path_pre apply blast + apply (rule CollectI, rule conjI) + using construct_path_inv apply blast + using construct_path_inv_termination apply clarsimp + by fastforce + + +end (* relation_algebra_rtc_tarski_choose_point_finite *) + +subsection \Topological sorting\ + +text \ +In our second example we look at topological sorting. +Given a directed acyclic graph, the problem is to construct a linear order of its vertices that contains $x$ before $y$ for each edge $(x,y)$ of the graph. +If the input graph models dependencies between tasks, the output is a linear schedule of the tasks that respects all dependencies. +\ + +context relation_algebra_rtc_tarski_choose_point +begin + +abbreviation topological_sort_inv + where "topological_sort_inv q v R W \ + regressively_finite R \ R \ v*v\<^sup>T \ W\<^sup>+ \ terminating_path W \ W*1 = v\-q \ + (W = 0 \ q = end_points W) \ point q \ R*v \ v \ q \ v \ is_vector v" + +lemma topological_sort_pre: + assumes "regressively_finite R" + shows "topological_sort_inv (choose_point (minimum R 1)) (choose_point (minimum R 1)) R 0" +proof (intro conjI,simp_all add:assms) + let ?q = "choose_point (- (R\<^sup>T * 1))" + show point_q: "point ?q" + using assms by (metis (full_types) annir choose_point_point galois_aux2 is_inj_def is_sur_def + is_vector_def one_idem_mult point_def ss_p18 inf_top_left one_compl) + show "R \ ?q * ?q\<^sup>T \ 0" + by (metis choose_point_decreasing conv_invol end_point_char eq_iff inf_bot_left schroeder_2) + show "path 0" + by (simp add: is_inj_def is_p_fun_def path_def) + show "R*?q \ ?q" + by (metis choose_point_decreasing compl_bot_eq conv_galois_1 inf_compl_bot_left2 le_inf_iff) + show "is_vector ?q" + using point_q point_def by blast +qed + +lemma topological_sort_inv: + assumes "v \ 1" + and "topological_sort_inv q v R W" + shows "topological_sort_inv (choose_point (minimum R (- v))) (v + + choose_point (minimum R (- v))) R (W + q * choose_point (minimum R (- v))\<^sup>T)" +proof (intro conjI) + let ?p = "choose_point (minimum R (-v))" + let ?W = "W + q*?p\<^sup>T" + let ?v = "v + ?p" + show point_p: "point ?p" + using assms + by (metis choose_point_point compl_bot_eq double_compl galois_aux2 comp_assoc is_vector_def + vector_compl vector_mult) + hence ep_np: "end_points (q*?p\<^sup>T) = ?p" + using assms(2) + by (metis aux4 choose_point_decreasing edge_end le_supI1 point_in_vector_or_complement_iff + point_is_point) + hence sp_q: "start_points (q*?p\<^sup>T) = q" + using assms(2) point_p + by (metis (no_types, lifting) conv_contrav conv_invol edge_start point_is_point) + hence ep_sp: "W \ 0 \ end_points W = start_points (q*?p\<^sup>T)" + using assms(2) by force + have "W*1 \ (q*?p\<^sup>T)\<^sup>T*1 = v\-q\?p" + using assms(2) point_p is_vector_def mult_assoc point_def point_equations(3) point_is_point + by auto + hence 1: "W*1 \ (q*?p\<^sup>T)\<^sup>T*1 = 0" + by (metis choose_point_decreasing dual_order.trans galois_aux inf.cobounded2 inf.commute) + + show "regressively_finite R" + using assms(2) by blast + show "R \ ?v*?v\<^sup>T \ ?W\<^sup>+" + proof - + have a: "R \ v*v\<^sup>T \ ?W\<^sup>+" + using assms(2) by (meson mult_isol_var order.trans order_prop star_subdist) + have b: "R \ v*?p\<^sup>T \ ?W\<^sup>+" + proof - + have "R \ v*?p\<^sup>T \ W*1*?p\<^sup>T + q*?p\<^sup>T" + by (metis inf_le2 assms(2) aux4 double_compl inf_absorb2 distrib_right) + also have "... = W*?p\<^sup>T + q*?p\<^sup>T" + using point_p by (metis conv_contrav conv_one is_vector_def mult_assoc point_def) + also have "... \ W\<^sup>+*end_points W*?p\<^sup>T + q*?p\<^sup>T" + using assms(2) + by (meson forward_terminating_path_end_points_1 join_iso mult_isor terminating_path_iff) + also have "... \ W\<^sup>+*q*?p\<^sup>T + q*?p\<^sup>T" + using assms(2) by (metis annil eq_refl) + also have "... = W\<^sup>\*q*?p\<^sup>T" + using conway.dagger_unfoldl_distr mult_assoc sup_commute by fastforce + also have "... \ ?W\<^sup>+" + by (metis mult_assoc mult_isol_var star_slide_var star_subdist sup_ge2) + finally show ?thesis . + qed + have c: "R \ ?p*v\<^sup>T \ ?W\<^sup>+" + proof - + have "v \ -?p" + using choose_point_decreasing compl_le_swap1 inf_le1 order_trans by blast + hence "R*v \ -?p" + using assms(2) order.trans by blast + thus ?thesis + by (metis galois_aux inf_le2 schroeder_2) + qed + have d: "R \ ?p*?p\<^sup>T \ ?W\<^sup>+" + proof - + have "R \ ?p*?p\<^sup>T \ R \ 1'" + using point_p is_inj_def meet_isor point_def by blast + also have "... = 0" + using assms(2) regressively_finite_irreflexive galois_aux by blast + finally show ?thesis + using bot_least inf.absorb_iff2 by simp + qed + have "R \ ?v*?v\<^sup>T = (R \ v*v\<^sup>T) + (R \ v*?p\<^sup>T) + (R \ ?p*v\<^sup>T) + (R \ ?p*?p\<^sup>T)" + by (metis conv_add distrib_left distrib_right inf_sup_distrib1 sup.commute sup.left_commute) + also have "... \ ?W\<^sup>+" + using a b c d by (simp add: le_sup_iff) + finally show ?thesis . + qed + show pathW: "path ?W" + proof (cases "W = 0") + assume "W = 0" + thus ?thesis + using assms(2) point_p edge_is_path point_is_point sup_bot_left by auto + next + assume a1: "W \ 0" + have fw_path: "forward_terminating_path W" + using assms(2) terminating_iff by blast + have bw_path: "backward_terminating_path (q*?p\<^sup>T)" + using assms point_p sp_q + by (metis conv_backward_terminating conv_has_start_points conv_path edge_is_path + forward_terminating_iff1 point_is_point start_point_iff2) + show ?thesis + using fw_path bw_path ep_sp 1 a1 path_concatenation_cycle_free by blast + qed + show "terminating ?W" + proof (rule start_end_implies_terminating) + show "has_start_points ?W" + apply (cases "W = 0") + using assms(2) sp_q pathW + apply (metis (no_types, lifting) point_is_point start_point_iff2 sup_bot.left_neutral) + using assms(2) ep_sp 1 pathW + by (metis has_start_end_points_iff path_concatenation_start_points start_point_iff2 + terminating_iff1) + show "has_end_points ?W" + apply (cases "W = 0") + using point_p ep_np ep_sp pathW end_point_iff2 point_is_point apply force + using point_p ep_np ep_sp 1 pathW + by (metis end_point_iff2 path_concatenation_end_points point_is_point) + qed + show "?W*1 = ?v\-?p" + proof - + have "?W*1 = v" + by (metis assms(2) point_p is_vector_def mult_assoc point_def point_equations(3) + point_is_point aux4 distrib_right' inf_absorb2 sup.commute) + also have "... = v\-?p" + by (metis choose_point_decreasing compl_le_swap1 inf.cobounded1 inf.orderE order_trans) + finally show ?thesis + by (simp add: inf_sup_distrib2) + qed + show "?W = 0 \ ?p = end_points ?W" + using ep_np ep_sp 1 by (metis path_concatenation_end_points sup_bot_left) + show "R*?v \ ?v" + using assms(2) + by (meson choose_point_decreasing conv_galois_1 inf.cobounded2 order.trans sup.coboundedI1 + sup_least) + show "?p \ ?v" + by simp + show "is_vector ?v" + using assms(2) point_p point_def vector_add by blast +qed + +lemma topological_sort_post: + assumes "\ v \ 1" + and "topological_sort_inv q v R W" + shows "R \ W\<^sup>+ \ terminating_path W \ (W + W\<^sup>T)*1 = -1'*1" +proof (intro conjI,simp_all add:assms) + show "R \ W\<^sup>+" + using assms by force + show " backward_terminating W \ W \ 1 * W * (- v + q)" + using assms by force + show "v \ - q + W\<^sup>T * 1 = - 1' * 1" + proof (cases "W = 0") + assume "W = 0" + thus ?thesis + using assms + by (metis compl_bot_eq conv_one conv_zero double_compl inf_top.left_neutral is_inj_def + le_bot mult_1_right one_idem_mult point_def ss_p18 star_zero sup.absorb2 top_le) + next + assume a1: "W \ 0" + hence "-1' \ 0" + using assms backward_terminating_path_irreflexive le_bot by fastforce + hence "1 = 1*-1'*1" + by (simp add: tarski) + also have "... = -1'*1" + by (metis comp_assoc distrib_left mult_1_left sup_top_left distrib_right sup_compl_top) + finally have a: "1 = -1'*1" . + have "W*1 + W\<^sup>T*1 = 1" + using assms a1 by (metis double_compl galois_aux4 inf.absorb_iff2 inf_top.left_neutral) + thus ?thesis + using a by (simp add: assms(2)) + qed +qed + +theorem topological_sort_partial: "VARS p q v W + { regressively_finite R } + W := 0; + q := choose_point (minimum R 1); + v := q; + WHILE v \ 1 + INV { topological_sort_inv q v R W } + DO p := choose_point (minimum R (-v)); + W := W + q*p\<^sup>T; + q := p; + v := v + p + OD + { R \ W\<^sup>+ \ terminating_path W \ (W + W\<^sup>T)*1 = -1'*1 }" + apply vcg + using topological_sort_pre apply blast + using topological_sort_inv apply blast + using topological_sort_post by blast + +end (* relation_algebra_rtc_tarski_choose_point *) + +context relation_algebra_rtc_tarski_choose_point_finite +begin + +lemma topological_sort_inv_termination: + assumes "v \ 1" + and "topological_sort_inv q v R W" + shows "card {z . z \ -(v + choose_point (minimum R (-v)))} < card { z . z \ -v }" +proof (rule decrease_variant) + let ?p = "choose_point (minimum R (-v))" + let ?v = "v + ?p" + show "-?v \ -v" + by simp + show "?p \ -v" + using choose_point_decreasing inf.boundedE by blast + have "point ?p" + using assms + by (metis choose_point_point compl_bot_eq double_compl galois_aux2 comp_assoc is_vector_def + vector_compl vector_mult) + thus "\ (?p \ -?v)" + by (metis annir compl_sup inf.absorb1 inf_compl_bot_right maddux_20 no_end_point_char) +qed + +text \ +Use precondition \is_acyclic\ instead of \regressively_finite\. +They are equivalent for finite graphs. +\ + +theorem topological_sort_total: "VARS p q v W + [ is_acyclic R ] + W := 0; + q := choose_point (minimum R 1); + v := q; + WHILE v \ 1 + INV { topological_sort_inv q v R W } + VAR { card { z . z \ -v } } + DO p := choose_point (minimum R (-v)); + W := W + q*p\<^sup>T; + q := p; + v := v + p + OD + [ R \ W\<^sup>+ \ terminating_path W \ (W + W\<^sup>T)*1 = -1'*1 ]" + apply vcg_tc + apply (drule acyclic_regressively_finite) + using topological_sort_pre apply blast + apply (rule CollectI, rule conjI) + using topological_sort_inv apply blast + using topological_sort_inv_termination apply auto[1] + using topological_sort_post by blast + +end (* relation_algebra_rtc_tarski_choose_point_finite *) + +subsection \Construction of a tree\ + +text \ +Our last application is a correctness proof of an algorithm that constructs a non-empty cycle for a given directed graph. +This works in two steps. +The first step is to construct a directed tree from a given root along the edges of the graph. +\ + +context relation_algebra_rtc_tarski_choose_point +begin + +abbreviation construct_tree_pre + where "construct_tree_pre x y R \ y \ R\<^sup>T\<^sup>\*x \ point x" +abbreviation construct_tree_inv + where "construct_tree_inv v x y D R \ construct_tree_pre x y R \ is_acyclic D \ is_inj D \ + D \ R \ D*x = 0 \ v = x + D\<^sup>T*1 \ x*v\<^sup>T \ D\<^sup>\ \ D \ v*v\<^sup>T \ + is_vector v" +abbreviation construct_tree_post + where "construct_tree_post x y D R \ is_acyclic D \ is_inj D \ D \ R \ D*x = 0 \ D\<^sup>T*1 \ D\<^sup>T\<^sup>\*x \ + D\<^sup>\*y \ D\<^sup>T\<^sup>\*x" + +lemma construct_tree_pre: + assumes "construct_tree_pre x y R" + shows "construct_tree_inv x x y 0 R" +using assms by (simp add: is_inj_def point_def) + +lemma construct_tree_inv_aux: + assumes "\ y \ v" + and "construct_tree_inv v x y D R" + shows "singleton (choose_singleton (v*-v\<^sup>T \ R))" +proof (rule choose_singleton_singleton, rule notI) + assume "v*-v\<^sup>T \ R = 0" + hence "R\<^sup>T\<^sup>\*v \ v" + by (metis galois_aux conv_compl conv_galois_1 conv_galois_2 conv_invol double_compl + star_inductl_var) + hence "y = 0" + using assms by (meson mult_isol order_trans sup.cobounded1) + thus False + using assms point_is_point by auto +qed + +lemma construct_tree_inv: + assumes "\ y \ v" + and "construct_tree_inv v x y D R" + shows "construct_tree_inv (v + choose_singleton (v*-v\<^sup>T \ R)\<^sup>T*1) x y (D + + choose_singleton (v*-v\<^sup>T \ R)) R" +proof (intro conjI) + let ?e = "choose_singleton (v*-v\<^sup>T \ R)" + let ?D = "D + ?e" + let ?v = "v + ?e\<^sup>T*1" + have 1: "?e \ v*-v\<^sup>T" + using choose_singleton_decreasing inf.boundedE by blast + show "point x" + by (simp add: assms) + show "y \ R\<^sup>T\<^sup>\*x" + by (simp add: assms) + show "is_acyclic ?D" + using 1 assms acyclic_inv by fastforce + show "is_inj ?D" + using 1 construct_tree_inv_aux assms injective_inv by blast + show "?D \ R" + apply (rule sup.boundedI) + using assms apply blast + using choose_singleton_decreasing inf.boundedE by blast + show "?D*x = 0" + proof - + have "?D*x = ?e*x" + by (simp add: assms) + also have "... \ ?e*v" + by (simp add: assms mult_isol) + also have "... \ v*-v\<^sup>T*v" + using 1 mult_isor by blast + also have "... = 0" + by (metis assms(2) annir comp_assoc vector_prop1) + finally show ?thesis + using le_bot by blast + qed + show "?v = x + ?D\<^sup>T*1" + by (simp add: assms sup_assoc) + show "x*?v\<^sup>T \ ?D\<^sup>\" + proof - + have "x*?v\<^sup>T = x*v\<^sup>T + x*1*?e" + by (simp add: distrib_left mult_assoc) + also have "... \ D\<^sup>\ + x*1*(?e \ v*-v\<^sup>T)" + using 1 by (metis assms(2) inf.absorb1 join_iso) + also have "... = D\<^sup>\ + x*1*(?e \ v \ -v\<^sup>T)" + by (metis assms(2) comp_assoc conv_compl inf.assoc vector_compl vector_meet_comp) + also have "... \ D\<^sup>\ + x*1*(?e \ v)" + using join_isol mult_subdistl by fastforce + also have "... = D\<^sup>\ + x*(1 \ v\<^sup>T)*?e" + by (metis assms(2) inf.commute mult_assoc vector_2) + also have "... = D\<^sup>\ + x*v\<^sup>T*?e" + by simp + also have "... \ D\<^sup>\ + D\<^sup>\*?e" + using assms join_isol mult_isor by blast + also have "... \ ?D\<^sup>\" + by (meson le_sup_iff prod_star_closure star_ext star_subdist) + finally show ?thesis . + qed + show "?D \ ?v*?v\<^sup>T" + proof (rule sup.boundedI) + show "D \ ?v*?v\<^sup>T" + using assms + by (meson conv_add distrib_left le_supI1 conv_iso dual_order.trans mult_isol_var order_prop) + have "?e \ v*(-v\<^sup>T \ v\<^sup>T*?e)" + using 1 inf.absorb_iff2 modular_1' by fastforce + also have "... \ v*1*?e" + by (simp add: comp_assoc le_infI2 mult_isol_var) + also have "... \ ?v*?v\<^sup>T" + by (metis conv_contrav conv_invol conv_iso conv_one mult_assoc mult_isol_var sup.cobounded1 + sup_ge2) + finally show "?e \ ?v*?v\<^sup>T" + by simp + qed + show "is_vector ?v" + using assms comp_assoc is_vector_def by fastforce +qed + +lemma construct_tree_post: + assumes "y \ v" + and "construct_tree_inv v x y D R" + shows "construct_tree_post x y D R" +proof - + have "v*x\<^sup>T \ D\<^sup>T\<^sup>\" + by (metis (no_types, lifting) assms(2) conv_contrav conv_invol conv_iso star_conv) + hence 1: "v \ D\<^sup>T\<^sup>\*x" + using assms point_def ss423bij by blast + hence 2: "D\<^sup>T*1 \ D\<^sup>T\<^sup>\*x" + using assms le_supE by blast + have "D\<^sup>\*y \ D\<^sup>T\<^sup>\*x" + proof (rule star_inductl, rule sup.boundedI) + show "y \ D\<^sup>T\<^sup>\*x" + using 1 assms order.trans by blast + next + have "D*(D\<^sup>T\<^sup>\*x) = D*x + D*D\<^sup>T\<^sup>+*x" + by (metis conway.dagger_unfoldl_distr distrib_left mult_assoc) + also have "... = D*D\<^sup>T\<^sup>+*x" + using assms by simp + also have "... \ 1'*D\<^sup>T\<^sup>\*x" + by (metis assms(2) is_inj_def mult_assoc mult_isor) + finally show "D*(D\<^sup>T\<^sup>\*x) \ D\<^sup>T\<^sup>\*x" + by simp + qed + thus "construct_tree_post x y D R" + using 2 assms by simp +qed + +theorem construct_tree_partial: "VARS e v D + { construct_tree_pre x y R } + D := 0; + v := x; + WHILE \ y \ v + INV { construct_tree_inv v x y D R } + DO e := choose_singleton (v*-v\<^sup>T \ R); + D := D + e; + v := v + e\<^sup>T*1 + OD + { construct_tree_post x y D R }" + apply vcg + using construct_tree_pre apply blast + using construct_tree_inv apply blast + using construct_tree_post by blast + +end (* relation_algebra_rtc_tarski_choose_point *) + +context relation_algebra_rtc_tarski_choose_point_finite +begin + +lemma construct_tree_inv_termination: + assumes " \ y \ v" + and "construct_tree_inv v x y D R" + shows "card { z . z \ -(v + choose_singleton (v*-v\<^sup>T \ R)\<^sup>T*1) } < card { z . z \ -v }" +proof (rule decrease_variant) + let ?e = "choose_singleton (v*-v\<^sup>T \ R)" + let ?v = "v + ?e\<^sup>T*1" + have 1: "?e \ v*-v\<^sup>T" + using choose_singleton_decreasing inf.boundedE by blast + have 2: "singleton ?e" + using construct_tree_inv_aux assms by auto + show "-?v \ -v" + by simp + have "?e\<^sup>T \ -v*v\<^sup>T" + using 1 conv_compl conv_iso by force + also have "... \ -v*1" + by (simp add: mult_isol) + finally show "?e\<^sup>T*1 \ -v" + using assms by (metis is_vector_def mult_isor one_compl) + thus "\ (?e\<^sup>T*1 \ -?v)" + using 2 by (metis annir compl_sup inf.absorb1 inf_compl_bot_right surj_one tarski) +qed + +theorem construct_tree_total: "VARS e v D + [ construct_tree_pre x y R ] + D := 0; + v := x; + WHILE \ y \ v + INV { construct_tree_inv v x y D R } + VAR { card { z . z \ -v } } + DO e := choose_singleton (v*-v\<^sup>T \ R); + D := D + e; + v := v + e\<^sup>T*1 + OD + [ construct_tree_post x y D R ]" + apply vcg_tc + using construct_tree_pre apply blast + apply (rule CollectI, rule conjI) + using construct_tree_inv apply blast + using construct_tree_inv_termination apply force + using construct_tree_post by blast + +end (* relation_algebra_rtc_tarski_choose_point_finite *) + +subsection \Construction of a non-empty cycle\ + +text \ +The second step is to construct a path from the root to a given vertex in the tree. +Adding an edge back to the root gives the cycle. +\ + +context relation_algebra_rtc_tarski_choose_point +begin + +abbreviation comment + where "comment _ \ SKIP" (* instead of inner comments *) +abbreviation construct_cycle_inv + where "construct_cycle_inv v x y D R \ construct_tree_inv v x y D R \ point y \ y*x\<^sup>T \ R" + +lemma construct_cycle_pre: + assumes " \ is_acyclic R" + and "y = choose_point ((R\<^sup>+ \ 1')*1)" + and "x = choose_point (R\<^sup>\*y \ R\<^sup>T*y)" + shows "construct_cycle_inv x x y 0 R" +proof(rule conjI, rule_tac [2] conjI) + show point_y: "point y" + using assms by (simp add: choose_point_point is_vector_def mult_assoc galois_aux ss_p18) + have "R\<^sup>\*y \ R\<^sup>T*y \ 0" + proof + have "R\<^sup>+ \ 1' = (R\<^sup>+)\<^sup>T \ 1'" + by (metis (mono_tags, hide_lams) conv_e conv_times inf.cobounded1 inf.commute + many_strongly_connected_iff_6_eq mult_oner star_subid) + also have "... = R\<^sup>T\<^sup>+ \ 1'" + using plus_conv by fastforce + also have "... \ (R\<^sup>T\<^sup>\ \ R)*R\<^sup>T" + by (metis conv_contrav conv_e conv_invol modular_2_var mult_oner star_slide_var) + also have "... \ (R\<^sup>T\<^sup>\ \ R)*1" + by (simp add: mult_isol) + finally have a: "(R\<^sup>+ \ 1')*1 \ (R\<^sup>T\<^sup>\ \ R)*1" + by (metis mult_assoc mult_isor one_idem_mult) + assume "R\<^sup>\*y \ R\<^sup>T*y = 0" + hence "(R\<^sup>\ \ R\<^sup>T)*y = 0" + using point_y inj_distr point_def by blast + hence "(R\<^sup>\ \ R\<^sup>T)\<^sup>T*1 \ -y" + by (simp add: conv_galois_1) + hence "y \ -((R\<^sup>\ \ R\<^sup>T)\<^sup>T*1)" + using compl_le_swap1 by blast + also have "... = -((R\<^sup>T\<^sup>\ \ R)*1)" + by (simp add: star_conv) + also have "... \ -((R\<^sup>+ \ 1')*1)" + using a comp_anti by blast + also have "... \ -y" + by (simp add: assms galois_aux ss_p18 choose_point_decreasing) + finally have "y = 0" + using inf.absorb2 by fastforce + thus False + using point_y annir point_equations(2) point_is_point tarski by force + qed + hence point_x: "point x" + by (metis point_y assms(3) inj_distr is_vector_def mult_assoc point_def choose_point_point) + hence "y \ R\<^sup>T\<^sup>\ * x" + by (metis assms(3) point_y choose_point_decreasing inf_le1 order.trans point_swap star_conv) + thus tree_inv: "construct_tree_inv x x y 0 R" + using point_x construct_tree_pre by blast + show "y * x\<^sup>T \ R" + proof - + have "x \ R\<^sup>\*y \ R\<^sup>T*y" + using assms(3) choose_point_decreasing by blast + also have "... = (R\<^sup>\ \ R\<^sup>T)*y" + using point_y inj_distr point_def by fastforce + finally have "x*y\<^sup>T \ R\<^sup>\ \ R\<^sup>T" + using point_y point_def ss423bij by blast + also have "... \ R\<^sup>T" + by simp + finally show ?thesis + using conv_iso by force + qed +qed + +lemma construct_cycle_pre2: + assumes "y \ v" + and "construct_cycle_inv v x y D R" + shows "construct_path_inv y x y D 0 \ D \ R \ D * x = 0 \ y * x\<^sup>T \ R" +proof(intro conjI, simp_all add: assms) + show "D\<^sup>\ * y \ D\<^sup>T\<^sup>\ * x" + using assms construct_tree_post by blast + show "path 0" + by (simp add: is_inj_def is_p_fun_def path_def) + show "y \ 0" + using assms(2) is_point_def point_is_point by blast +qed + +lemma construct_cycle_post: + assumes "\ q \ x" + and "(construct_path_inv q x y D W \ D \ R \ D * x = 0 \ y * x\<^sup>T \ R)" + shows "W + y * x\<^sup>T \ 0 \ W + y * x\<^sup>T \ R \ cycle (W + y * x\<^sup>T)" +proof(intro conjI) + let ?C = "W + y*x\<^sup>T" + show "?C \ 0" + by (metis assms acyclic_imp_one_step_different_points(2) no_trivial_inverse point_def ss423bij + sup_bot.monoid_axioms monoid.left_neutral) + show "?C \ R" + using assms(2) order_trans sup.boundedI by blast + show "path (W + y * x\<^sup>T)" + by (metis assms construct_tree_pre edge_is_path less_eq_def path_edge_equals_cycle + point_is_point terminating_iff1) + show "many_strongly_connected (W + y * x\<^sup>T)" + by (metis assms construct_tree_pre bot_least conv_zero less_eq_def + path_edge_equals_cycle star_conv star_subid terminating_iff1) + qed + +theorem construct_cycle_partial: "VARS e p q v x y C D W + { \ is_acyclic R } + y := choose_point ((R\<^sup>+ \ 1')*1); + x := choose_point (R\<^sup>\*y \ R\<^sup>T*y); + D := 0; + v := x; + WHILE \ y \ v + INV { construct_cycle_inv v x y D R } + DO e := choose_singleton (v*-v\<^sup>T \ R); + D := D + e; + v := v + e\<^sup>T*1 + OD; + comment { is_acyclic D \ point y \ point x \ D\<^sup>\*y \ D\<^sup>T\<^sup>\*x }; + W := 0; + q := y; + WHILE q \ x + INV { construct_path_inv q x y D W \ D \ R \ D*x = 0 \ y*x\<^sup>T \ R } + DO p := choose_point (D*q); + W := W + p*q\<^sup>T; + q := p + OD; + comment { W \ D \ terminating_path W \ (W = 0 \ q=y) \ (W \ 0 \ q = start_points W \ y = end_points W) }; + C := W + y*x\<^sup>T + { C \ 0 \ C \ R \ cycle C }" + apply vcg + using construct_cycle_pre apply blast + using construct_tree_inv apply blast + using construct_cycle_pre2 apply blast + using construct_path_inv apply blast + using construct_cycle_post by blast + +end (* relation_algebra_rtc_tarski_choose_point *) + +context relation_algebra_rtc_tarski_choose_point_finite +begin + +theorem construct_cycle_total: "VARS e p q v x y C D W + [ \ is_acyclic R ] + y := choose_point ((R\<^sup>+ \ 1')*1); + x := choose_point (R\<^sup>\*y \ R\<^sup>T*y); + D := 0; + v := x; + WHILE \ y \ v + INV { construct_cycle_inv v x y D R } + VAR { card { z . z \ -v } } + DO e := choose_singleton (v*-v\<^sup>T \ R); + D := D + e; + v := v + e\<^sup>T*1 + OD; + comment { is_acyclic D \ point y \ point x \ D\<^sup>\*y \ D\<^sup>T\<^sup>\*x }; + W := 0; + q := y; + WHILE q \ x + INV { construct_path_inv q x y D W \ D \ R \ D*x = 0 \ y*x\<^sup>T \ R } + VAR { card { z . z \ -W } } + DO p := choose_point (D*q); + W := W + p*q\<^sup>T; + q := p + OD; + comment { W \ D \ terminating_path W \ (W = 0 \ q=y) \ (W \ 0 \ q = start_points W \ y = end_points W)}; + C := W + y*x\<^sup>T + [ C \ 0 \ C \ R \ cycle C ]" + apply vcg_tc + using construct_cycle_pre apply blast + apply (rule CollectI, rule conjI) + using construct_tree_inv apply blast + using construct_tree_inv_termination apply force + using construct_cycle_pre2 apply blast + apply (rule CollectI, rule conjI) + using construct_path_inv apply blast + using construct_path_inv_termination apply clarsimp + using construct_cycle_post by blast + +end (* relation_algebra_rtc_tarski_choose_point_finite *) + +end diff --git a/thys/Relational_Paths/Paths.thy b/thys/Relational_Paths/Paths.thy new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/Paths.thy @@ -0,0 +1,2307 @@ +(* Title: Relational Characterisation of Paths + Author: Walter Guttmann, Peter Hoefner + Maintainer: Walter Guttmann + Peter Hoefner +*) + +section \Relational Characterisation of Paths\ + +text \ +This theory provides the relation-algebraic characterisations of paths, as defined in Sections 3--5 of \cite{BerghammerFurusawaGuttmannHoefner2020}. +\ + +theory Paths + +imports More_Relation_Algebra + +begin + +context relation_algebra_tarski +begin + +lemma path_concat_aux_0: + assumes "is_vector v" + and "v \ 0" + and "w;v\<^sup>T \ x" + and "v;z \ y" + shows "w;1;z \ x;y" +proof - + from tarski assms(1,2) have "1 = 1;v\<^sup>T;v;1" + by (metis conv_contrav conv_one eq_refl inf_absorb1 inf_top_left is_vector_def ra_2) + hence "w;1;z = w;1;v\<^sup>T;v;1;z" + by (simp add: mult_isor mult_isol mult_assoc) + also from assms(1) have "... = w;v\<^sup>T;v;z" + by (metis is_vector_def comp_assoc conv_contrav conv_one) + also from assms(3) have "... \ x;v;z" + by (simp add: mult_isor) + also from assms(4) have "... \ x;y" + by (simp add: mult_isol mult_assoc) + finally show ?thesis . +qed + +end (* context relation_algebra_tarski *) + +subsection \Consequences without the Tarski rule\ + +context relation_algebra_rtc +begin + +text \Definitions for path classifications\ + +abbreviation connected + where "connected x \ x;1;x \ x\<^sup>\ + x\<^sup>T\<^sup>\" + +abbreviation many_strongly_connected + where "many_strongly_connected x \ x\<^sup>\ = x\<^sup>T\<^sup>\" + +abbreviation one_strongly_connected + where "one_strongly_connected x \ x\<^sup>T;1;x\<^sup>T \ x\<^sup>\" + +definition path + where "path x \ connected x \ is_p_fun x \ is_inj x" + +abbreviation cycle + where "cycle x \ path x \ many_strongly_connected x" + +abbreviation start_points + where "start_points x \ x;1 \ -(x\<^sup>T;1)" + +abbreviation end_points + where "end_points x \ x\<^sup>T;1 \ -(x;1)" + +abbreviation no_start_points + where "no_start_points x \ x;1 \ x\<^sup>T;1" + +abbreviation no_end_points + where "no_end_points x \ x\<^sup>T;1 \ x;1" + +abbreviation no_start_end_points + where "no_start_end_points x \ x;1 = x\<^sup>T;1" + +abbreviation has_start_points + where "has_start_points x \ 1 = -(1;x);x;1" + +abbreviation has_end_points + where "has_end_points x \ 1 = 1;x;-(x;1)" + +abbreviation has_start_end_points + where "has_start_end_points x \ 1 = -(1;x);x;1 \ 1;x;-(x;1)" + +abbreviation backward_terminating + where "backward_terminating x \ x \ -(1;x);x;1" + +abbreviation forward_terminating + where "forward_terminating x \ x \ 1;x;-(x;1)" + +abbreviation terminating + where "terminating x \ x \ -(1;x);x;1 \ 1;x;-(x;1)" + +abbreviation backward_finite + where "backward_finite x \ x \ x\<^sup>T\<^sup>\ + -(1;x);x;1" + +abbreviation forward_finite + where "forward_finite x \ x \ x\<^sup>T\<^sup>\ + 1;x;-(x;1)" + +abbreviation finite + where "finite x \ x \ x\<^sup>T\<^sup>\ + (-(1;x);x;1 \ 1;x;-(x;1))" + +abbreviation no_start_points_path + where "no_start_points_path x \ path x \ no_start_points x" + +abbreviation no_end_points_path + where "no_end_points_path x \ path x \ no_end_points x" + +abbreviation no_start_end_points_path + where "no_start_end_points_path x \ path x \ no_start_end_points x" + +abbreviation has_start_points_path + where "has_start_points_path x \ path x \ has_start_points x" + +abbreviation has_end_points_path + where "has_end_points_path x \ path x \ has_end_points x" + +abbreviation has_start_end_points_path + where "has_start_end_points_path x \ path x \ has_start_end_points x" + +abbreviation backward_terminating_path + where "backward_terminating_path x \ path x \ backward_terminating x" + +abbreviation forward_terminating_path + where "forward_terminating_path x \ path x \ forward_terminating x" + +abbreviation terminating_path + where "terminating_path x \ path x \ terminating x" + +abbreviation backward_finite_path + where "backward_finite_path x \ path x \ backward_finite x" + +abbreviation forward_finite_path + where "forward_finite_path x \ path x \ forward_finite x" + +abbreviation finite_path + where "finite_path x \ path x \ finite x" + +text \General properties\ + +lemma reachability_from_z_in_y: + assumes "x \ y\<^sup>\;z" + and "x \ z = 0" + shows "x \ y\<^sup>+;z" +by (metis assms conway.dagger_unfoldl_distr galois_1 galois_aux inf.orderE) + +lemma reachable_imp: + assumes "point p" + and "point q" + and "p\<^sup>\;q \ p\<^sup>T\<^sup>\;p" + shows "p \ p\<^sup>\;q" +by (metis assms conway.dagger_unfoldr_distr le_supE point_swap star_conv) + +text \Basic equivalences\ + +lemma no_start_end_points_iff: + "no_start_end_points x \ no_start_points x \ no_end_points x" +by fastforce + +lemma has_start_end_points_iff: + "has_start_end_points x \ has_start_points x \ has_end_points x" +by (metis inf_eq_top_iff) + +lemma terminating_iff: + "terminating x \ backward_terminating x \ forward_terminating x" +by simp + +lemma finite_iff: + "finite x \ backward_finite x \ forward_finite x" +by (simp add: sup_inf_distrib1 inf.boundedI) + +lemma no_start_end_points_path_iff: + "no_start_end_points_path x \ no_start_points_path x \ no_end_points_path x" +by fastforce + +lemma has_start_end_points_path_iff: + "has_start_end_points_path x \ has_start_points_path x \ has_end_points_path x" +using has_start_end_points_iff by blast + +lemma terminating_path_iff: + "terminating_path x \ backward_terminating_path x \ forward_terminating_path x" +by fastforce + +lemma finite_path_iff: + "finite_path x \ backward_finite_path x \ forward_finite_path x" +using finite_iff by fastforce + +text \Closure under converse\ + +lemma connected_conv: + "connected x \ connected (x\<^sup>T)" +by (metis comp_assoc conv_add conv_contrav conv_iso conv_one star_conv) + +lemma conv_many_strongly_connected: + "many_strongly_connected x \ many_strongly_connected (x\<^sup>T)" +by fastforce + +lemma conv_one_strongly_connected: + "one_strongly_connected x \ one_strongly_connected (x\<^sup>T)" +by (metis comp_assoc conv_contrav conv_iso conv_one star_conv) + +lemma conv_path: + "path x \ path (x\<^sup>T)" +using connected_conv inj_p_fun path_def by fastforce + +lemma conv_cycle: + "cycle x \ cycle (x\<^sup>T)" +using conv_path by fastforce + +lemma conv_no_start_points: + "no_start_points x \ no_end_points (x\<^sup>T)" +by simp + +lemma conv_no_start_end_points: + "no_start_end_points x \ no_start_end_points (x\<^sup>T)" +by fastforce + +lemma conv_has_start_points: + "has_start_points x \ has_end_points (x\<^sup>T)" +by (metis comp_assoc conv_compl conv_contrav conv_invol conv_one) + +lemma conv_has_start_end_points: + "has_start_end_points x \ has_start_end_points (x\<^sup>T)" +by (metis comp_assoc conv_compl conv_contrav conv_invol conv_one inf_eq_top_iff) + +lemma conv_backward_terminating: + "backward_terminating x \ forward_terminating (x\<^sup>T)" +by (metis comp_assoc conv_compl conv_contrav conv_iso conv_one) + +lemma conv_terminating: + "terminating x \ terminating (x\<^sup>T)" + apply (rule iffI) + apply (metis conv_compl conv_contrav conv_one conv_times inf.commute le_iff_inf mult_assoc) +by (metis conv_compl conv_contrav conv_invol conv_one conv_times inf.commute le_iff_inf mult_assoc) + +lemma conv_backward_finite: + "backward_finite x \ forward_finite (x\<^sup>T)" +by (metis comp_assoc conv_add conv_compl conv_contrav conv_iso conv_one star_conv) + +lemma conv_finite: + "finite x \ finite (x\<^sup>T)" +by (metis finite_iff conv_backward_finite conv_invol) + +lemma conv_no_start_points_path: + "no_start_points_path x \ no_end_points_path (x\<^sup>T)" +using conv_path by fastforce + +lemma conv_no_start_end_points_path: + "no_start_end_points_path x \ no_start_end_points_path (x\<^sup>T)" +using conv_path by fastforce + +lemma conv_has_start_points_path: + "has_start_points_path x \ has_end_points_path (x\<^sup>T)" +using conv_has_start_points conv_path by fastforce + +lemma conv_has_start_end_points_path: + "has_start_end_points_path x \ has_start_end_points_path (x\<^sup>T)" +using conv_has_start_end_points conv_path by fastforce + +lemma conv_backward_terminating_path: + "backward_terminating_path x \ forward_terminating_path (x\<^sup>T)" +using conv_backward_terminating conv_path by fastforce + +lemma conv_terminating_path: + "terminating_path x \ terminating_path (x\<^sup>T)" +using conv_path conv_terminating by fastforce + +lemma conv_backward_finite_path: + "backward_finite_path x \ forward_finite_path (x\<^sup>T)" +using conv_backward_finite conv_path by fastforce + +lemma conv_finite_path: + "finite_path x \ finite_path (x\<^sup>T)" +using conv_finite conv_path by blast + +text \Equivalences for \connected\\ + +lemma connected_iff2: + assumes "is_inj x" + and "is_p_fun x" + shows "connected x \ x;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +proof + assume 1: "connected x" + have "x;1;x\<^sup>T \ x;1;x;x\<^sup>T" + by (metis conv_invol modular_var_3 vector_meet_comp_x') + also have "... \ (x\<^sup>+ + x\<^sup>T\<^sup>\);x\<^sup>T" + using 1 mult_isor star_star_plus by fastforce + also have "... \ x\<^sup>\;x;x\<^sup>T + x\<^sup>T\<^sup>\" + using join_isol star_slide_var by simp + also from assms(1) have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + by (metis is_inj_def comp_assoc join_iso mult_1_right mult_isol) + finally show "x;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" . +next + assume 2: "x;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" + have "x;1;x \ x;1;x\<^sup>T;x" + by (simp add: modular_var_3 vector_meet_comp_x) + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>+);x" + using 2 by (metis mult_isor star_star_plus sup_commute) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\;x\<^sup>T;x" + using join_iso star_slide_var by simp + also from assms(2) have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + by (metis comp_assoc is_p_fun_def join_isol mult_1_right mult_isol) + finally show "connected x" . +qed + +lemma connected_iff3: + assumes "is_inj x" + and "is_p_fun x" + shows "connected x \ x\<^sup>T;1;x \ x\<^sup>\ + x\<^sup>T\<^sup>\" +by (metis assms connected_conv connected_iff2 inj_p_fun p_fun_inj conv_invol add_commute) + +lemma connected_iff4: + "connected x \ x\<^sup>T;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +by (metis connected_conv conv_invol add_commute) + +lemma connected_iff5: + "connected x \ x\<^sup>+;1;x\<^sup>+ \ x\<^sup>\ + x\<^sup>T\<^sup>\" +using comp_assoc plus_top top_plus by fastforce + +lemma connected_iff6: + assumes "is_inj x" + and "is_p_fun x" + shows "connected x \ x\<^sup>+;1;(x\<^sup>+)\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +using assms connected_iff2 comp_assoc plus_conv plus_top top_plus by fastforce + +lemma connected_iff7: + assumes "is_inj x" + and "is_p_fun x" + shows "connected x \ (x\<^sup>+)\<^sup>T;1;x\<^sup>+ \ x\<^sup>\ + x\<^sup>T\<^sup>\" +by (metis assms connected_iff3 conv_contrav conv_invol conv_one top_plus vector_meet_comp_x) + +lemma connected_iff8: + "connected x \ (x\<^sup>+)\<^sup>T;1;(x\<^sup>+)\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +by (metis connected_iff4 comp_assoc conv_contrav conv_invol conv_one plus_conv star_conv top_plus) + +text \Equivalences and implications for \many_strongly_connected\\ + +lemma many_strongly_connected_iff_1: + "many_strongly_connected x \ x\<^sup>T \ x\<^sup>\" + apply (rule iffI,simp) +by (metis conv_invol conv_iso eq_iff star_conv star_invol star_iso) + +lemma many_strongly_connected_iff_2: + "many_strongly_connected x \ x\<^sup>T \ x\<^sup>+" +proof + assume as: "many_strongly_connected x" + hence "x\<^sup>T \ x\<^sup>\ \ (-(1') + x)" + by (metis many_strongly_connected_iff_1 loop_backward_forward inf_greatest) + also have "... \ (x\<^sup>\ \ -(1')) + (x\<^sup>\ \ x)" + by (simp add: inf_sup_distrib1) + also have "... \ x\<^sup>+" + by (metis as eq_iff mult_1_right mult_isol star_ref sup.absorb1 conv_invol eq_refl galois_1 + inf.absorb_iff1 inf.commute star_unfoldl_eq sup_mono many_strongly_connected_iff_1) + finally show "x\<^sup>T \ x\<^sup>+" . +next + show "x\<^sup>T \ x\<^sup>+ \ many_strongly_connected x" + using order_trans star_1l many_strongly_connected_iff_1 by blast +qed + +lemma many_strongly_connected_iff_3: + "many_strongly_connected x \ x \ x\<^sup>T\<^sup>\" +by (metis conv_invol many_strongly_connected_iff_1) + +lemma many_strongly_connected_iff_4: + "many_strongly_connected x \ x \ x\<^sup>T\<^sup>+" +by (metis conv_invol many_strongly_connected_iff_2) + +lemma many_strongly_connected_iff_5: + "many_strongly_connected x \ x\<^sup>\;x\<^sup>T \ x\<^sup>+" +by (metis comp_assoc conv_contrav conway.dagger_unfoldr_distr star_conv star_denest_var_2 + star_invol star_trans_eq star_unfoldl_eq sup.boundedE many_strongly_connected_iff_2) + +lemma many_strongly_connected_iff_6: + "many_strongly_connected x \ x\<^sup>T;x\<^sup>\ \ x\<^sup>+" +by (metis dual_order.trans star_1l star_conv star_inductl_star star_invol star_slide_var + many_strongly_connected_iff_1 many_strongly_connected_iff_5) + +lemma many_strongly_connected_iff_7: + "many_strongly_connected x \ x\<^sup>T\<^sup>+ = x\<^sup>+" +by (metis antisym conv_invol star_slide_var star_unfoldl_eq many_strongly_connected_iff_5) + +lemma many_strongly_connected_iff_5_eq: + "many_strongly_connected x \ x\<^sup>\;x\<^sup>T = x\<^sup>+" +by (metis order.refl star_slide_var many_strongly_connected_iff_5 many_strongly_connected_iff_7) + +lemma many_strongly_connected_iff_6_eq: + "many_strongly_connected x \ x\<^sup>T;x\<^sup>\ = x\<^sup>+" +using many_strongly_connected_iff_6 many_strongly_connected_iff_7 by force + +lemma many_strongly_connected_implies_no_start_end_points: + assumes "many_strongly_connected x" + shows "no_start_end_points x" +by (metis assms conway.dagger_unfoldl_distr mult_assoc sup_top_left conv_invol + many_strongly_connected_iff_7) + +lemma many_strongly_connected_implies_8: + assumes "many_strongly_connected x" + shows "x;x\<^sup>T \ x\<^sup>+" +by (simp add: assms mult_isol) + +lemma many_strongly_connected_implies_9: + assumes "many_strongly_connected x" + shows "x\<^sup>T;x \ x\<^sup>+" +by (metis assms eq_refl phl_cons1 star_ext star_slide_var) + +lemma many_strongly_connected_implies_10: + assumes "many_strongly_connected x" + shows "x;x\<^sup>T;x\<^sup>\ \ x\<^sup>+" +by (simp add: assms comp_assoc mult_isol) + +lemma many_strongly_connected_implies_10_eq: + assumes "many_strongly_connected x" + shows "x;x\<^sup>T;x\<^sup>\ = x\<^sup>+" +proof (rule antisym) + show "x;x\<^sup>T;x\<^sup>\ \ x\<^sup>+" + by (simp add: assms comp_assoc mult_isol) +next + have "x\<^sup>+ \ x;x\<^sup>T;x;x\<^sup>\" + using mult_isor x_leq_triple_x by blast + thus "x\<^sup>+ \ x;x\<^sup>T;x\<^sup>\" + by (simp add: comp_assoc mult_isol order_trans) +qed + +lemma many_strongly_connected_implies_11: + assumes "many_strongly_connected x" + shows "x\<^sup>\;x\<^sup>T;x \ x\<^sup>+" +by (metis assms conv_contrav conv_iso mult_isol star_1l star_slide_var) + +lemma many_strongly_connected_implies_11_eq: + assumes "many_strongly_connected x" + shows "x\<^sup>\;x\<^sup>T;x = x\<^sup>+" +by (metis assms comp_assoc conv_invol many_strongly_connected_iff_5_eq + many_strongly_connected_implies_10_eq) + +lemma many_strongly_connected_implies_12: + assumes "many_strongly_connected x" + shows "x\<^sup>\;x;x\<^sup>T \ x\<^sup>+" +by (metis assms comp_assoc mult_isol star_1l star_slide_var) + +lemma many_strongly_connected_implies_12_eq: + assumes "many_strongly_connected x" + shows "x\<^sup>\;x;x\<^sup>T = x\<^sup>+" +by (metis assms comp_assoc star_slide_var many_strongly_connected_implies_10_eq) + +lemma many_strongly_connected_implies_13: + assumes "many_strongly_connected x" + shows "x\<^sup>T;x;x\<^sup>\ \ x\<^sup>+" +by (metis assms star_slide_var many_strongly_connected_implies_11 mult.assoc) + +lemma many_strongly_connected_implies_13_eq: + assumes "many_strongly_connected x" + shows "x\<^sup>T;x;x\<^sup>\ = x\<^sup>+" +by (metis assms conv_invol many_strongly_connected_iff_7 many_strongly_connected_implies_10_eq) + +lemma many_strongly_connected_iff_8: + assumes "is_p_fun x" + shows "many_strongly_connected x \ x;x\<^sup>T \ x\<^sup>+" + apply (rule iffI) + apply (simp add: mult_isol) + apply (simp add: many_strongly_connected_iff_1) +by (metis comp_assoc conv_invol dual_order.trans mult_isol x_leq_triple_x assms comp_assoc + dual_order.trans is_p_fun_def order.refl prod_star_closure star_ref) + +lemma many_strongly_connected_iff_9: + assumes "is_inj x" + shows "many_strongly_connected x \ x\<^sup>T;x \ x\<^sup>+" +by (metis assms conv_contrav conv_iso inj_p_fun star_conv star_slide_var + many_strongly_connected_iff_1 many_strongly_connected_iff_8) + +lemma many_strongly_connected_iff_10: + assumes "is_p_fun x" + shows "many_strongly_connected x \ x;x\<^sup>T;x\<^sup>\ \ x\<^sup>+" + apply (rule iffI) + apply (simp add: comp_assoc mult_isol) +by (metis assms mult_isol mult_oner order_trans star_ref many_strongly_connected_iff_8) + +lemma many_strongly_connected_iff_10_eq: + assumes "is_p_fun x" + shows "many_strongly_connected x \ x;x\<^sup>T;x\<^sup>\ = x\<^sup>+" +using assms many_strongly_connected_iff_10 many_strongly_connected_implies_10_eq by fastforce + +lemma many_strongly_connected_iff_11: + assumes "is_inj x" + shows "many_strongly_connected x \ x\<^sup>\;x\<^sup>T;x \ x\<^sup>+" +by (metis assms comp_assoc conv_contrav conv_iso inj_p_fun plus_conv star_conv + many_strongly_connected_iff_10 many_strongly_connected_iff_2) + +lemma many_strongly_connected_iff_11_eq: + assumes "is_inj x" + shows "many_strongly_connected x \ x\<^sup>\;x\<^sup>T;x = x\<^sup>+" +using assms many_strongly_connected_iff_11 many_strongly_connected_implies_11_eq by fastforce + +lemma many_strongly_connected_iff_12: + assumes "is_p_fun x" + shows "many_strongly_connected x \ x\<^sup>\;x;x\<^sup>T \ x\<^sup>+" +by (metis assms dual_order.trans mult_double_iso mult_oner star_ref star_slide_var + many_strongly_connected_iff_8 many_strongly_connected_implies_12) + +lemma many_strongly_connected_iff_12_eq: + assumes "is_p_fun x" + shows "many_strongly_connected x \ x\<^sup>\;x;x\<^sup>T = x\<^sup>+" +using assms many_strongly_connected_iff_12 many_strongly_connected_implies_12_eq by fastforce + +lemma many_strongly_connected_iff_13: + assumes "is_inj x" + shows "many_strongly_connected x \ x\<^sup>T;x;x\<^sup>\ \ x\<^sup>+" +by (metis assms comp_assoc conv_contrav conv_iso inj_p_fun star_conv star_slide_var + many_strongly_connected_iff_1 many_strongly_connected_iff_12) + +lemma many_strongly_connected_iff_13_eq: + assumes "is_inj x" + shows "many_strongly_connected x \ x\<^sup>T;x;x\<^sup>\ = x\<^sup>+" +using assms many_strongly_connected_iff_13 many_strongly_connected_implies_13_eq by fastforce + +text \Equivalences and implications for \one_strongly_connected\\ + +lemma one_strongly_connected_iff: + "one_strongly_connected x \ connected x \ many_strongly_connected x" + apply (rule iffI) + apply (metis top_greatest x_leq_triple_x mult_double_iso top_greatest dual_order.trans + many_strongly_connected_iff_1 comp_assoc conv_contrav conv_invol conv_iso le_supI2 + star_conv) +by (metis comp_assoc conv_contrav conv_iso conv_one conway.dagger_denest star_conv star_invol + star_sum_unfold star_trans_eq) + +lemma one_strongly_connected_iff_1: + "one_strongly_connected x \ x\<^sup>T;1;x\<^sup>T \ x\<^sup>+" +proof + assume 1: "one_strongly_connected x" + have "x\<^sup>T;1;x\<^sup>T \ x\<^sup>T;x;x\<^sup>T;1;x\<^sup>T" + by (metis conv_invol mult_isor x_leq_triple_x) + also from 1 have "... \ x\<^sup>T;x;x\<^sup>\" + by (metis distrib_left mult_assoc sup.absorb_iff1) + also from 1 have "... \ x\<^sup>+" + using many_strongly_connected_implies_13 one_strongly_connected_iff by blast + finally show "x\<^sup>T;1;x\<^sup>T \ x\<^sup>+" + . +next + assume "x\<^sup>T;1;x\<^sup>T \ x\<^sup>+" + thus "one_strongly_connected x" + using dual_order.trans star_1l by blast +qed + +lemma one_strongly_connected_iff_1_eq: + "one_strongly_connected x \ x\<^sup>T;1;x\<^sup>T = x\<^sup>+" + apply (rule iffI, simp_all) +by (metis comp_assoc conv_contrav conv_invol mult_double_iso plus_conv star_slide_var top_greatest + top_plus many_strongly_connected_implies_10_eq one_strongly_connected_iff eq_iff + one_strongly_connected_iff_1) + +lemma one_strongly_connected_iff_2: + "one_strongly_connected x \ x;1;x \ x\<^sup>T\<^sup>\" +by (metis conv_invol eq_refl less_eq_def one_strongly_connected_iff) + +lemma one_strongly_connected_iff_3: + "one_strongly_connected x \ x;1;x \ x\<^sup>T\<^sup>+" +by (metis comp_assoc conv_contrav conv_invol conv_iso conv_one star_conv + one_strongly_connected_iff_1) + +lemma one_strongly_connected_iff_3_eq: + "one_strongly_connected x \ x;1;x = x\<^sup>T\<^sup>+" +by (metis conv_invol one_strongly_connected_iff_1_eq one_strongly_connected_iff_2) + +lemma one_strongly_connected_iff_4_eq: + "one_strongly_connected x \ x\<^sup>T;1;x = x\<^sup>+" + apply (rule iffI) + apply (metis comp_assoc top_plus many_strongly_connected_iff_7 one_strongly_connected_iff + one_strongly_connected_iff_1_eq) +by (metis comp_assoc conv_contrav conv_invol conv_one plus_conv top_plus + one_strongly_connected_iff_1_eq) + +lemma one_strongly_connected_iff_5_eq: + "one_strongly_connected x \ x;1;x\<^sup>T = x\<^sup>+" +using comp_assoc conv_contrav conv_invol conv_one plus_conv top_plus many_strongly_connected_iff_7 + one_strongly_connected_iff one_strongly_connected_iff_3_eq by metis + +lemma one_strongly_connected_iff_6_aux: + "x;x\<^sup>+ \ x;1;x" +by (metis comp_assoc maddux_21 mult_isol top_plus) + +lemma one_strongly_connected_implies_6_eq: + assumes "one_strongly_connected x" + shows "x;1;x = x;x\<^sup>+" +by (metis assms comp_assoc many_strongly_connected_iff_7 many_strongly_connected_implies_10_eq + one_strongly_connected_iff one_strongly_connected_iff_3_eq) + +lemma one_strongly_connected_iff_7_aux: + "x\<^sup>+ \ x;1;x" +by (metis le_infI maddux_20 maddux_21 plus_top top_plus vector_meet_comp_x') + +lemma one_strongly_connected_implies_7_eq: + assumes "one_strongly_connected x" + shows "x;1;x = x\<^sup>+" +using assms many_strongly_connected_iff_7 one_strongly_connected_iff one_strongly_connected_iff_3_eq +by force + +lemma one_strongly_connected_implies_8: + assumes "one_strongly_connected x" + shows "x;1;x \ x\<^sup>\" +using assms one_strongly_connected_iff by fastforce + +lemma one_strongly_connected_iff_4: + assumes "is_inj x" + shows "one_strongly_connected x \ x\<^sup>T;1;x \ x\<^sup>+" +proof + assume "one_strongly_connected x" + thus "x\<^sup>T;1;x \ x\<^sup>+" + by (simp add: one_strongly_connected_iff_4_eq) +next + assume 1: "x\<^sup>T;1;x \ x\<^sup>+" + hence "x\<^sup>T;1;x\<^sup>T \ x\<^sup>\;x;x\<^sup>T" + by (metis mult_isor star_slide_var comp_assoc conv_invol modular_var_3 vector_meet_comp_x + order.trans) + also from assms have "... \ x\<^sup>\" + using comp_assoc is_inj_def mult_isol mult_oner by fastforce + finally show "one_strongly_connected x" + using dual_order.trans star_1l by fastforce +qed + +lemma one_strongly_connected_iff_5: + assumes "is_p_fun x" + shows "one_strongly_connected x \ x;1;x\<^sup>T \ x\<^sup>+" + apply (rule iffI) + using one_strongly_connected_iff_5_eq apply simp +by (metis assms comp_assoc mult_double_iso order.trans star_slide_var top_greatest top_plus + many_strongly_connected_iff_12 many_strongly_connected_iff_7 one_strongly_connected_iff_3) + +lemma one_strongly_connected_iff_6: + assumes "is_p_fun x" + and "is_inj x" + shows "one_strongly_connected x \ x;1;x \ x;x\<^sup>+" +proof + assume "one_strongly_connected x" + thus "x;1;x \ x;x\<^sup>+" + by (simp add: one_strongly_connected_implies_6_eq) +next + assume 1: "x;1;x \ x;x\<^sup>+" + have "x\<^sup>T;1;x \ x\<^sup>T;x;x\<^sup>T;1;x" + by (metis conv_invol mult_isor x_leq_triple_x) + also have "... \ x\<^sup>T;x;1;x" + by (metis comp_assoc mult_double_iso top_greatest) + also from 1 have "... \ x\<^sup>T;x;x\<^sup>+" + by (simp add: comp_assoc mult_isol) + also from assms(1) have "... \ x\<^sup>+" + by (metis comp_assoc is_p_fun_def mult_isor mult_onel) + finally show "one_strongly_connected x" + using assms(2) one_strongly_connected_iff_4 by blast +qed + +lemma one_strongly_connected_iff_6_eq: + assumes "is_p_fun x" + and "is_inj x" + shows "one_strongly_connected x \ x;1;x = x;x\<^sup>+" + apply (rule iffI) + using one_strongly_connected_implies_6_eq apply blast +by (simp add: assms one_strongly_connected_iff_6) + +text \Start points and end points\ + +lemma start_end_implies_terminating: + assumes "has_start_points x" + and "has_end_points x" + shows "terminating x" +using assms by simp + +lemma start_points_end_points_conv: + "start_points x = end_points (x\<^sup>T)" +by simp + +lemma start_point_at_most_one: + assumes "path x" + shows "is_inj (start_points x)" +proof - + have isvec: "is_vector (x;1 \ -(x\<^sup>T;1))" + by (simp add: comp_assoc is_vector_def one_compl vector_1) + + have "x;1 \ 1;x\<^sup>T \ x;1;x;x\<^sup>T" + by (metis comp_assoc conv_contrav conv_one inf.cobounded2 mult_1_right mult_isol one_conv ra_2) + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);x\<^sup>T" + using \path x\ by (metis path_def mult_isor) + also have "... = x\<^sup>T + x\<^sup>+;x\<^sup>T + x\<^sup>T\<^sup>+" + by (simp add: star_slide_var) + also have "... \ x\<^sup>T\<^sup>+ + x\<^sup>+;x\<^sup>T + x\<^sup>T\<^sup>+" + by (metis add_iso mult_1_right star_unfoldl_eq subdistl) + also have "... \ x\<^sup>\;x;x\<^sup>T + x\<^sup>T\<^sup>+" + by (simp add: star_slide_var add_comm) + also have "... \ x\<^sup>\;1' + x\<^sup>T\<^sup>+" + using \path x\ by (metis path_def is_inj_def comp_assoc distrib_left join_iso less_eq_def) + also have "... = 1' + x\<^sup>\;x + x\<^sup>T;x\<^sup>T\<^sup>\" + by simp + also have "... \ 1' + 1;x + x\<^sup>T;1" + by (metis join_isol mult_isol mult_isor sup.mono top_greatest) + finally have aux: "x;1 \ 1;x\<^sup>T \ 1' + 1;x + x\<^sup>T;1" . + + from aux have "x;1 \ 1;x\<^sup>T \ -(x\<^sup>T;1) \ -(1;x) \ 1'" + by (simp add: galois_1 sup_commute) + hence "(x;1 \ -(x\<^sup>T;1)) \ (x;1 \ -(x\<^sup>T;1))\<^sup>T \ 1'" + by (simp add: conv_compl inf.assoc inf.left_commute) + with isvec have "(x;1 \ -(x\<^sup>T;1)) ; (x;1 \ -(x\<^sup>T;1))\<^sup>T \ 1'" + by (metis vector_meet_comp') + thus "is_inj (start_points x)" + by (simp add: conv_compl is_inj_def) +qed + +lemma start_point_zero_point: + assumes "path x" + shows "start_points x = 0 \ is_point (start_points x)" +using assms start_point_at_most_one comp_assoc is_point_def is_vector_def vector_compl vector_mult +by simp + +lemma start_point_iff1: + assumes "path x" + shows "is_point (start_points x) \ \(no_start_points x)" +using assms start_point_zero_point galois_aux2 is_point_def by blast + +lemma end_point_at_most_one: + assumes "path x" + shows "is_inj (end_points x)" +by (metis assms conv_path compl_bot_eq conv_invol inj_def_var1 is_point_def top_greatest + start_point_zero_point) + +lemma end_point_zero_point: + assumes "path x" + shows "end_points x = 0 \ is_point (end_points x)" +using assms conv_path start_point_zero_point by fastforce + +lemma end_point_iff1: + assumes "path x" + shows "is_point (end_points x) \ \(no_end_points x)" +using assms end_point_zero_point galois_aux2 is_point_def by blast + +lemma predecessor_point': + assumes "path x" + and "point s" + and "point e" + and "e;s\<^sup>T \ x" + shows "x;s = e" +proof (rule antisym) + show 1: "e \ x ; s" + using assms(2,4) point_def ss423bij by blast + show "x ; s \ e" + proof - + have "e\<^sup>T ; (x ; s) = 1" + using 1 by (metis assms(3) eq_iff is_vector_def point_def ss423conv top_greatest) + thus ?thesis + by (metis assms(1-3) comp_assoc conv_contrav conv_invol eq_iff inj_compose is_vector_def + mult_isol path_def point_def ss423conv sur_def_var1 top_greatest) + qed +qed + +lemma predecessor_point: + assumes "path x" + and "point s" + and "point e" + and "e;s\<^sup>T \ x" + shows "point(x;s)" +using predecessor_point' assms by blast + +lemma points_of_path_iff: + shows "(x + x\<^sup>T);1 = x\<^sup>T;1 + start_points(x)" + and "(x + x\<^sup>T);1 = x;1 + end_points(x)" +using aux9 inf.commute sup.commute by auto + +text \Path concatenation preliminaries\ + +lemma path_concat_aux_1: + assumes "x;1 \ y;1 \ y\<^sup>T;1 = 0" + and "end_points x = start_points y" + shows "x;1 \ y;1 = 0" +proof - + have "x;1 \ y;1 = (x;1 \ y;1 \ y\<^sup>T;1) + (x;1 \ y;1 \ -(y\<^sup>T;1))" + by simp + also from assms(1) have "... = x;1 \ y;1 \ -(y\<^sup>T;1)" + by (metis aux6_var de_morgan_3 inf.left_commute inf_compl_bot inf_sup_absorb) + also from assms(2) have "... = x;1 \ x\<^sup>T;1 \ -(x;1)" + by (simp add: inf.assoc) + also have "... = 0" + by (simp add: inf.commute inf.assoc) + finally show ?thesis . +qed + +lemma path_concat_aux_2: + assumes "x;1 \ x\<^sup>T;1 \ y\<^sup>T;1 = 0" + and "end_points x = start_points y" + shows "x\<^sup>T;1 \ y\<^sup>T;1 = 0" +proof - + have "y\<^sup>T;1 \ x\<^sup>T;1 \ (x\<^sup>T)\<^sup>T;1 = 0" + using assms(1) inf.assoc inf.commute by force + thus ?thesis + by (metis assms(2) conv_invol inf.commute path_concat_aux_1) +qed + +lemma path_concat_aux3_1: + assumes "path x" + shows "x;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +proof - + have "x;1;x\<^sup>T \ x;1;x\<^sup>T;x;x\<^sup>T" + by (metis comp_assoc conv_invol mult_isol x_leq_triple_x) + also have "... \ x;1;x;x\<^sup>T" + by (metis mult_isol mult_isor mult_assoc top_greatest) + also from assms have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);x\<^sup>T" + using path_def comp_assoc mult_isor by blast + also have "... = x\<^sup>\;x;x\<^sup>T + x\<^sup>T\<^sup>\;x\<^sup>T" + by (simp add: star_slide_var star_star_plus) + also have "... \ x\<^sup>\;1' + x\<^sup>T\<^sup>\;x\<^sup>T" + by (metis assms path_def is_inj_def join_iso mult_isol mult_assoc) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using join_isol by simp + finally show ?thesis . +qed + +lemma path_concat_aux3_2: + assumes "path x" + shows "x\<^sup>T;1;x \ x\<^sup>\ + x\<^sup>T\<^sup>\" +proof - + have "x\<^sup>T;1;x \ x\<^sup>T;x;x\<^sup>T;1;x" + by (metis comp_assoc conv_invol mult_isor x_leq_triple_x) + also have "... \ x\<^sup>T;x;1;x" + by (metis mult_isol mult_isor mult_assoc top_greatest) + also from assms have "... \ x\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\)" + by (simp add: comp_assoc mult_isol path_def) + also have "... = x\<^sup>T;x;x\<^sup>\ + x\<^sup>T;x\<^sup>T\<^sup>\" + by (simp add: comp_assoc distrib_left star_star_plus) + also have "... \ 1';x\<^sup>\ + x\<^sup>T;x\<^sup>T\<^sup>\" + by (metis assms path_def is_p_fun_def join_iso mult_isor mult_assoc) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using join_isol by simp + finally show ?thesis . +qed + +lemma path_concat_aux3_3: + assumes "path x" + shows "x\<^sup>T;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +proof - + have "x\<^sup>T;1;x\<^sup>T \ x\<^sup>T;x;x\<^sup>T;1;x\<^sup>T" + by (metis comp_assoc conv_invol mult_isor x_leq_triple_x) + also have "... \ x\<^sup>T;x;1;x\<^sup>T" + by (metis mult_isol mult_isor mult_assoc top_greatest) + also from assms have "... \ x\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\)" + using path_concat_aux3_1 by (simp add: mult_assoc mult_isol) + also have "... = x\<^sup>T;x;x\<^sup>\ + x\<^sup>T;x\<^sup>T\<^sup>\" + by (simp add: comp_assoc distrib_left star_star_plus) + also have "... \ 1';x\<^sup>\ + x\<^sup>T;x\<^sup>T\<^sup>\" + by (metis assms path_def is_p_fun_def join_iso mult_isor mult_assoc) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using join_isol by simp + finally show ?thesis . +qed + +lemma path_concat_aux_3: + assumes "path x" + and "y \ x\<^sup>+ + x\<^sup>T\<^sup>+" + and "z \ x\<^sup>+ + x\<^sup>T\<^sup>+" + shows "y;1;z \ x\<^sup>\ + x\<^sup>T\<^sup>\" +proof - + from assms(2,3) have "y;1;z \ (x\<^sup>+ + x\<^sup>T\<^sup>+);1;(x\<^sup>+ + x\<^sup>T\<^sup>+)" + using mult_isol_var mult_isor by blast + also have "... = x\<^sup>+;1;x\<^sup>+ + x\<^sup>+;1;x\<^sup>T\<^sup>+ + x\<^sup>T\<^sup>+;1;x\<^sup>+ + x\<^sup>T\<^sup>+;1;x\<^sup>T\<^sup>+" + by (simp add: distrib_left sup_commute sup_left_commute) + also have "... = x;x\<^sup>\;1;x\<^sup>\;x + x;x\<^sup>\;1;x\<^sup>T\<^sup>\;x\<^sup>T + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>\;x + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>T\<^sup>\;x\<^sup>T" + by (simp add: comp_assoc star_slide_var) + also have "... \ x;1;x + x;x\<^sup>\;1;x\<^sup>T\<^sup>\;x\<^sup>T + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>\;x + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>T\<^sup>\;x\<^sup>T" + by (metis comp_assoc mult_double_iso top_greatest join_iso) + also have "... \ x;1;x + x;1;x\<^sup>T + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>\;x + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>T\<^sup>\;x\<^sup>T" + by (metis comp_assoc mult_double_iso top_greatest join_iso join_isol) + also have "... \ x;1;x + x;1;x\<^sup>T + x\<^sup>T;1;x + x\<^sup>T;x\<^sup>T\<^sup>\;1;x\<^sup>T\<^sup>\;x\<^sup>T" + by (metis comp_assoc mult_double_iso top_greatest join_iso join_isol) + also have "... \ x;1;x + x;1;x\<^sup>T + x\<^sup>T;1;x + x\<^sup>T;1;x\<^sup>T" + by (metis comp_assoc mult_double_iso top_greatest join_isol) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using assms(1) path_def path_concat_aux3_1 path_concat_aux3_2 path_concat_aux3_3 join_iso join_isol + by simp + finally show ?thesis . +qed + +lemma path_concat_aux_4: + "x\<^sup>\ + x\<^sup>T\<^sup>\ \ x\<^sup>\ + x\<^sup>T;1" +by (metis star_star_plus add_comm join_isol mult_isol top_greatest) + +lemma path_concat_aux_5: + assumes "path x" + and "y \ start_points x" + and "z \ x + x\<^sup>T" + shows "y;1;z \ x\<^sup>\" +proof - + from assms(1) have "x;1;x \ x\<^sup>\ + x\<^sup>T;1" + using path_def path_concat_aux_4 dual_order.trans by blast + hence aux1: "x;1;x \ -(x\<^sup>T;1) \ x\<^sup>\" + by (simp add: galois_1 sup_commute) + + from assms(1) have "x;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T;1" + using dual_order.trans path_concat_aux3_1 path_concat_aux_4 by blast + hence aux2: "x;1;x\<^sup>T \ -(x\<^sup>T;1) \ x\<^sup>\" + by (simp add: galois_1 sup_commute) + + from assms(2,3) have "y;1;z \ (x;1 \ -(x\<^sup>T;1));1;(x + x\<^sup>T)" + by (simp add: mult_isol_var mult_isor) + also have "... = (x;1 \ -(x\<^sup>T;1));1;x + (x;1 \ -(x\<^sup>T;1));1;x\<^sup>T" + using distrib_left by blast + also have "... = (x;1 \ -(x\<^sup>T;1) \ 1;x) + (x;1 \ -(x\<^sup>T;1));1;x\<^sup>T" + by (metis comp_assoc inf_top_right is_vector_def one_idem_mult vector_1 vector_compl) + also have "... = (x;1 \ -(x\<^sup>T;1) \ 1;x) + (x;1 \ -(x\<^sup>T;1) \ 1;x\<^sup>T)" + by (metis comp_assoc inf_top_right is_vector_def one_idem_mult vector_1 vector_compl) + also have "... = (x;1;x \ -(x\<^sup>T;1)) + (x;1;x\<^sup>T -(x\<^sup>T;1))" + using vector_meet_comp_x vector_meet_comp_x' diff_eq inf.assoc inf.commute by simp + also from aux1 aux2 have "... \ x\<^sup>\" + by (simp add: diff_eq join_iso) + finally show ?thesis . +qed + +lemma path_conditions_disjoint_points_iff: + "x;1 \ (x\<^sup>T;1 + y;1) \ y\<^sup>T;1 = 0 \ start_points x \ end_points y = 0 \ x;1 \ y\<^sup>T;1 = 0" +proof + assume 1: "x ; 1 \ y\<^sup>T ; 1 = 0" + hence g1: "x ; 1 \ (x\<^sup>T ; 1 + y ; 1) \ y\<^sup>T ; 1 = 0" + by (metis inf.left_commute inf_bot_right inf_commute) + have g2: "start_points x \ end_points y = 0" + using 1 by (metis compl_inf_bot inf.assoc inf.commute inf.left_idem) + show "x;1 \ (x\<^sup>T;1 + y;1) \ y\<^sup>T;1 = 0 \ start_points x \ end_points y = 0" + using g1 and g2 by simp +next + assume a: "x;1 \ (x\<^sup>T;1 + y;1) \ y\<^sup>T;1 = 0 \ start_points x \ end_points y = 0" + from a have a1: "x;1 \ x\<^sup>T;1 \ y\<^sup>T;1 = 0" + by (simp add: inf.commute inf_sup_distrib1) + from a have a2: "x;1 \ y;1 \ y\<^sup>T;1 = 0" + by (simp add: inf.commute inf_sup_distrib1) + from a have a3: "start_points x \ end_points y = 0" + by blast + + have "x;1 \ y\<^sup>T;1 = x;1 \ x\<^sup>T;1 \ y\<^sup>T;1 + x;1 \ -(x\<^sup>T;1) \ y\<^sup>T;1" + by (metis aux4 inf_sup_distrib2) + also from a1 have "... = x;1 \ -(x\<^sup>T;1) \ y\<^sup>T;1" + using sup_bot_left by blast + also have "... = x;1 \ -(x\<^sup>T;1) \ y;1 \ y\<^sup>T;1 + x;1 \ -(x\<^sup>T;1) \ -(y;1) \ y\<^sup>T;1" + by (metis aux4 inf_sup_distrib2) + also have "... \ x;1 \ y;1 \ y\<^sup>T;1 + x;1 \ -(x\<^sup>T;1) \ -(y;1) \ y\<^sup>T;1" + using join_iso meet_iso by simp + also from a2 have "... = start_points x \ end_points y" + using sup_bot_left inf.commute inf.left_commute by simp + also from a3 have "... = 0" + by blast + finally show "x;1 \ y\<^sup>T;1 = 0" + using le_bot by blast +qed + +end (* end relation_algebra_rtc *) + +subsection \Consequences with the Tarski rule\ + +context relation_algebra_rtc_tarski +begin + +text \General theorems\ + +lemma reachable_implies_predecessor: + assumes "p \ q" + and "point p" + and "point q" + and "x\<^sup>\;q \ x\<^sup>T\<^sup>\;p" + shows "x;q \ 0" +proof + assume contra: "x;q=0" + with assms(4) have "q \ x\<^sup>T\<^sup>\;p" + by (simp add: independence1) + hence "p \ x\<^sup>\;q" + by (metis assms(2,3) point_swap star_conv) + with contra assms(2,3) have "p=q" + by (simp add: independence1 is_point_def point_singleton point_is_point) + with assms(1) show False + by simp +qed + +lemma acyclic_imp_one_step_different_points: + assumes "is_acyclic x" + and "point p" + and "point q" + and "p \ x;q" + shows "p \ -q" and "p \ q" +using acyclic_reachable_points assms point_is_point point_not_equal(1) by auto + +text \Start points and end points\ + +lemma start_point_iff2: + assumes "path x" + shows "is_point (start_points x) \ has_start_points x" +proof - + have "has_start_points x \ 1 \ -(1;x);x;1" + by (simp add: eq_iff) + also have "... \ 1 \ 1;x\<^sup>T;-(x\<^sup>T;1)" + by (metis comp_assoc conv_compl conv_contrav conv_iso conv_one) + also have "... \ 1 \ 1;(x;1 \ -(x\<^sup>T;1))" + by (metis (no_types) conv_contrav conv_one inf.commute is_vector_def one_idem_mult ra_2 vector_1 + vector_meet_comp_x) + also have "... \ 1 = 1;(x;1 \ -(x\<^sup>T;1))" + by (simp add: eq_iff) + also have "... \ x;1 \ -(x\<^sup>T;1) \ 0" + by (metis tarski comp_assoc one_compl ra_1 ss_p18) + also have "... \ is_point (start_points x)" + using assms is_point_def start_point_zero_point by blast + finally show ?thesis .. +qed + +lemma end_point_iff2: + assumes "path x" + shows "is_point (end_points x) \ has_end_points x" +by (metis assms conv_invol conv_has_start_points conv_path start_point_iff2) + +lemma edge_is_path: + assumes "is_point p" + and "is_point q" + shows "path (p;q\<^sup>T)" + apply (unfold path_def; intro conjI) + apply (metis assms comp_assoc is_point_def le_supI1 star_ext vector_rectangle point_equations(3)) + apply (metis is_p_fun_def assms comp_assoc conv_contrav conv_invol is_inj_def is_point_def + vector_2_var vector_meet_comp_x' point_equations) + by (metis is_inj_def assms conv_invol conv_times is_point_def p_fun_mult_var vector_meet_comp) + +lemma edge_start: + assumes "is_point p" + and "is_point q" + and "p \ q" + shows "start_points (p;q\<^sup>T) = p" +using assms by (simp add: comp_assoc point_equations(1,3) point_not_equal inf.absorb1) + +lemma edge_end: + assumes "is_point p" + and "is_point q" + and "p \ q" + shows "end_points (p;q\<^sup>T) = q" +using assms edge_start by simp + +lemma loop_no_start: + assumes "is_point p" + shows "start_points (p;p\<^sup>T) = 0" +by simp + +lemma loop_no_end: + assumes "is_point p" + shows "end_points (p;p\<^sup>T) = 0" +by simp + +lemma start_point_no_predecessor: + "x;start_points(x) = 0" +by (metis inf_top.right_neutral modular_1_aux') + +lemma end_point_no_successor: + "x\<^sup>T;end_points(x) = 0" +by (metis conv_invol start_point_no_predecessor) + +lemma start_to_end: + assumes "path x" + shows "start_points(x);end_points(x)\<^sup>T \ x\<^sup>\" +proof (cases "end_points(x) = 0") + assume "end_points(x) = 0" + thus ?thesis + by simp +next + assume ass: "end_points(x) \ 0" + hence nz: "x;end_points(x) \ 0" + by (metis comp_res_aux compl_bot_eq inf.left_idem) + have a: "x;end_points(x);end_points(x)\<^sup>T \ x + x\<^sup>T" + by (metis end_point_at_most_one assms(1) is_inj_def comp_assoc mult_isol mult_oner le_supI1) + + have "start_points(x);end_points(x)\<^sup>T = start_points(x);1;end_points(x)\<^sup>T" + using ass by (simp add: comp_assoc is_vector_def one_compl vector_1) + also have "... = start_points(x);1;x;end_points(x);1;end_points(x)\<^sup>T" + using nz tarski by (simp add: comp_assoc) + also have "... = start_points(x);1;x;end_points(x);end_points(x)\<^sup>T" + using ass by (simp add: comp_assoc is_vector_def one_compl vector_1) + also with a assms(1) have "... \ x\<^sup>\" + using path_concat_aux_5 comp_assoc eq_refl by simp + finally show ?thesis . +qed + +lemma path_acyclic: + assumes "has_start_points_path x" + shows "is_acyclic x" +proof - + let ?r = "start_points(x)" + have pt: "point(?r)" + using assms point_is_point start_point_iff2 by blast + have "x\<^sup>+\1' = (x\<^sup>+)\<^sup>T\x\<^sup>+\1'" + by (metis conv_e conv_times inf.assoc inf.left_idem inf_le2 many_strongly_connected_iff_7 + mult_oner star_subid) + also have "... \ x\<^sup>T;1\x\<^sup>+\1'" + by (metis conv_contrav inf.commute maddux_20 meet_double_iso plus_top star_conv star_slide_var) + finally have "?r;(x\<^sup>+\1') \ ?r;(x\<^sup>T;1\x\<^sup>+\1')" + using mult_isol by blast + also have "... = (?r\1;x);(x\<^sup>+\1')" + by (metis (no_types, lifting) comp_assoc conv_contrav conv_invol conv_one inf.assoc + is_vector_def one_idem_mult vector_2) + also have "... = ?r;x;(x\<^sup>+\1')" + by (metis comp_assoc inf_top.right_neutral is_vector_def one_compl one_idem_mult vector_1) + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);(x\<^sup>+\1')" + using assms(1) mult_isor + by (meson connected_iff4 dual_order.trans mult_subdistr path_concat_aux3_3) + also have "... = x\<^sup>\;(x\<^sup>+\1') + x\<^sup>T\<^sup>+;(x\<^sup>+\1')" + by (metis distrib_right star_star_plus sup.commute) + also have "... \ x\<^sup>\;(x\<^sup>+\1') + x\<^sup>T;1" + by (metis join_isol mult_isol plus_top top_greatest) + finally have "?r;(x\<^sup>+\1');1 \ x\<^sup>\;(x\<^sup>+\1');1 + x\<^sup>T;1" + by (metis distrib_right inf_absorb2 mult_assoc mult_subdistr one_idem_mult) + hence 1: "?r;(x\<^sup>+\1');1 \ x\<^sup>T;1" + using assms(1) path_def inj_implies_step_forwards_backwards sup_absorb2 by simp + have "x\<^sup>+\1' \ (x\<^sup>+\1');1" + by (simp add: maddux_20) + also have "... \ ?r\<^sup>T;?r;(x\<^sup>+\1');1" + using pt comp_assoc point_def ss423conv by fastforce + also have "... \ ?r\<^sup>T;x\<^sup>T;1" + using 1 by (simp add: comp_assoc mult_isol) + also have "... = 0" + by (metis start_point_no_predecessor annil conv_contrav conv_zero) + finally show ?thesis + using galois_aux le_bot by blast +qed + +text \Equivalences for \terminating\\ + +lemma backward_terminating_iff1: + assumes "path x" + shows "backward_terminating x \ has_start_points x \ x = 0" +proof + assume "backward_terminating x" + hence "1;x;1 \ 1;-(1;x);x;1;1" + by (metis mult_isor mult_isol comp_assoc) + also have "... = -(1;x);x;1" + by (metis conv_compl conv_contrav conv_invol conv_one mult_assoc one_compl one_idem_mult) + finally have "1;x;1 \ -(1;x);x;1" . + + with tarski show "has_start_points x \ x = 0" + by (metis top_le) +next + show "has_start_points x \ x = 0 \ backward_terminating x" + by fastforce +qed + +lemma backward_terminating_iff2_aux: + assumes "path x" + shows "x;1 \ 1;x\<^sup>T \ -(1;x) \ x\<^sup>T\<^sup>\" +proof - + have "x;1 \ 1;x\<^sup>T \ x;1;x;x\<^sup>T" + by (metis conv_invol modular_var_3 vector_meet_comp_x vector_meet_comp_x') + also from assms have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);x\<^sup>T" + using path_def mult_isor by blast + also have "... \ x\<^sup>\;x;x\<^sup>T + x\<^sup>T\<^sup>\;x\<^sup>T" + by (simp add: star_star_plus star_slide_var add_comm) + also from assms have "... \ x\<^sup>\;1' + x\<^sup>T\<^sup>\;x\<^sup>T" + by (metis path_def is_inj_def join_iso mult_assoc mult_isol) + also have "... = x\<^sup>+ + x\<^sup>T\<^sup>\" + by (metis mult_1_right star_slide_var star_star_plus sup.commute) + also have "... \ x\<^sup>T\<^sup>\ + 1;x" + by (metis join_iso mult_isor star_slide_var top_greatest add_comm) + finally have "x;1 \ 1;x\<^sup>T \ x\<^sup>T\<^sup>\ + 1;x" . + thus ?thesis + by (simp add: galois_1 sup.commute) +qed + +lemma backward_terminating_iff2: + assumes "path x" + shows "backward_terminating x \ x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" +proof + assume "backward_terminating x" + with assms have "has_start_points x \ x = 0" + by (simp add: backward_terminating_iff1) + thus "x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + proof + assume "x = 0" + thus ?thesis + by simp + next + assume "has_start_points x" + hence aux1: "1 = 1;x\<^sup>T;-(x\<^sup>T;1)" + by (metis comp_assoc conv_compl conv_contrav conv_one) + have "x = x \ 1" + by simp + also have "... \ (x;-(1;x) \ 1;x\<^sup>T);-(x\<^sup>T;1)" + by (metis inf.commute aux1 conv_compl conv_contrav conv_invol conv_one modular_2_var) + also have "... = (x;1 \ -(1;x) \ 1;x\<^sup>T);-(x\<^sup>T;1)" + by (metis comp_assoc conv_compl conv_contrav conv_invol conv_one inf.commute inf_top_left + one_compl ra_1) + also from assms have "... \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + using backward_terminating_iff2_aux inf.commute inf.assoc mult_isor by fastforce + finally show "x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" . + qed +next + assume "x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + hence"x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1) \ x" + by simp + also have "... = (x\<^sup>T\<^sup>\ \ -(1;x));1 \ x" + by (metis one_compl conv_compl conv_contrav conv_invol conv_one inf_top_left ra_2) + also have "... \ (x\<^sup>T\<^sup>\ \ -(1;x)) ; (1 \ (x\<^sup>\ \ -(1;x)\<^sup>T);x)" + by (metis (mono_tags) conv_compl conv_invol conv_times modular_1_var star_conv) + also have "... \ -(1;x);x\<^sup>\;x" + by (simp add: mult_assoc mult_isol_var) + also have "... \ -(1;x);x;1" + by (simp add: mult_assoc mult_isol star_slide_var) + finally show "backward_terminating x" . +qed + +lemma backward_terminating_iff3_aux: + assumes "path x" + shows "x\<^sup>T;1 \ 1;x\<^sup>T \ -(1;x) \ x\<^sup>T\<^sup>\" +proof - + have "x\<^sup>T;1 \ 1;x\<^sup>T \ x\<^sup>T;1;x;x\<^sup>T" + by (metis conv_invol modular_var_3 vector_meet_comp_x vector_meet_comp_x') + also from assms have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);x\<^sup>T" + using mult_isor path_concat_aux3_2 by blast + also have "... \ x\<^sup>\;x;x\<^sup>T + x\<^sup>T\<^sup>\;x\<^sup>T" + by (simp add: star_star_plus star_slide_var add_comm) + also from assms have "... \ x\<^sup>\;1' + x\<^sup>T\<^sup>\;x\<^sup>T" + by (metis path_def is_inj_def join_iso mult_assoc mult_isol) + also have "... = x\<^sup>+ + x\<^sup>T\<^sup>\" + by (metis mult_1_right star_slide_var star_star_plus sup.commute) + also have "... \ x\<^sup>T\<^sup>\ + 1;x" + by (metis join_iso mult_isor star_slide_var top_greatest add_comm) + finally have "x\<^sup>T;1 \ 1;x\<^sup>T \ x\<^sup>T\<^sup>\ + 1;x" . + thus ?thesis + by (simp add: galois_1 sup.commute) +qed + +lemma backward_terminating_iff3: + assumes "path x" + shows "backward_terminating x \ x\<^sup>T \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" +proof + assume "backward_terminating x" + with assms have "has_start_points x \ x = 0" + by (simp add: backward_terminating_iff1) + thus "x\<^sup>T \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + proof + assume "x = 0" + thus ?thesis + by simp + next + assume "has_start_points x" + hence aux1: "1 = 1;x\<^sup>T;-(x\<^sup>T;1)" + by (metis comp_assoc conv_compl conv_contrav conv_one) + have "x\<^sup>T = x\<^sup>T \ 1" + by simp + also have "... \ (x\<^sup>T;-(1;x) \ 1;x\<^sup>T);-(x\<^sup>T;1)" + by (metis inf.commute aux1 conv_compl conv_contrav conv_invol conv_one modular_2_var) + also have "... = (x\<^sup>T;1 \ -(1;x) \ 1;x\<^sup>T);-(x\<^sup>T;1)" + by (metis comp_assoc conv_compl conv_contrav conv_invol conv_one inf.commute inf_top_left one_compl ra_1) + also from assms have "... \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + using backward_terminating_iff3_aux inf.commute inf.assoc mult_isor by fastforce + finally show "x\<^sup>T \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" . + qed +next + have 1: "-(1;x) \ x = 0" + by (simp add: galois_aux2 inf.commute maddux_21) + assume "x\<^sup>T \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + hence "x = -(1;x);x\<^sup>\ \ x" + by (metis (mono_tags, lifting) conv_compl conv_contrav conv_iso conv_one inf.absorb2 star_conv) + also have "... = (-(1;x);x\<^sup>+ + -(1;x);1') \ x" + by (metis distrib_left star_unfoldl_eq sup_commute) + also have "... = -(1;x);x\<^sup>+ \ x + -(1;x) \ x" + by (simp add: inf_sup_distrib2) + also have "... \ -(1;x);x\<^sup>+" + using 1 by simp + also have "... \ -(1;x);x;1" + by (simp add: mult_assoc mult_isol star_slide_var) + finally show "backward_terminating x" . +qed + +lemma backward_terminating_iff4: + assumes "path x" + shows "backward_terminating x \ x \ -(1;x);x\<^sup>\" + apply (subst backward_terminating_iff3) + apply (rule assms) + by (metis (mono_tags, lifting) conv_compl conv_iso star_conv conv_contrav conv_one) + +lemma forward_terminating_iff1: + assumes "path x" + shows "forward_terminating x \ has_end_points x \ x = 0" +by (metis comp_assoc eq_refl le_bot one_compl tarski top_greatest) + +lemma forward_terminating_iff2: + assumes "path x" + shows "forward_terminating x \ x\<^sup>T \ x\<^sup>\;-(x;1)" +by (metis assms backward_terminating_iff1 backward_terminating_iff2 end_point_iff2 + forward_terminating_iff1 compl_bot_eq conv_compl conv_invol conv_one conv_path + double_compl start_point_iff2) + +lemma forward_terminating_iff3: + assumes "path x" + shows "forward_terminating x \ x \ x\<^sup>\;-(x;1)" +by (metis assms backward_terminating_iff1 backward_terminating_iff3 end_point_iff2 + forward_terminating_iff1 compl_bot_eq conv_compl conv_invol conv_one conv_path + double_compl start_point_iff2) + +lemma forward_terminating_iff4: + assumes "path x" + shows "forward_terminating x \ x \ -(1;x\<^sup>T);x\<^sup>T\<^sup>\" +using forward_terminating_iff2 conv_contrav conv_iso star_conv assms conv_compl by force + +lemma terminating_iff1: + assumes "path x" + shows "terminating x \ has_start_end_points x \ x = 0" +using assms backward_terminating_iff1 forward_terminating_iff1 by fastforce + +lemma terminating_iff2: + assumes "path x" + shows "terminating x \ x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1) \ -(1;x\<^sup>T);x\<^sup>T\<^sup>\" +using assms backward_terminating_iff2 forward_terminating_iff2 conv_compl conv_iso star_conv +by force + +lemma terminating_iff3: + assumes "path x" + shows "terminating x \ x \ x\<^sup>\;-(x;1) \ -(1;x);x\<^sup>\" +using assms backward_terminating_iff4 forward_terminating_iff3 by fastforce + +lemma backward_terminating_path_irreflexive: + assumes "backward_terminating_path x" + shows "x \ -1'" +proof - + have 1: "x;x\<^sup>T \ 1'" + using assms is_inj_def path_def by blast + have "x;(x\<^sup>T \ 1') \ x;x\<^sup>T \ x" + by (metis inf.bounded_iff inf.commute mult_1_right mult_subdistl) + also have "... \ 1' \ x" + using 1 meet_iso by blast + also have "... = 1' \ x\<^sup>T" + by (metis conv_e conv_times inf.cobounded1 is_test_def test_eq_conv) + finally have 2: "x\<^sup>T;-(x\<^sup>T \ 1') \ -(x\<^sup>T \ 1')" + by (metis compl_le_swap1 conv_galois_1 inf.commute) + have "x\<^sup>T \ 1' \ x\<^sup>T;1" + by (simp add: le_infI1 maddux_20) + hence "-(x\<^sup>T;1) \ -(x\<^sup>T \ 1')" + using compl_mono by blast + hence "x\<^sup>T;-(x\<^sup>T \ 1') + -(x\<^sup>T;1) \ -(x\<^sup>T \ 1')" + using 2 by (simp add: le_supI) + hence "x\<^sup>T\<^sup>\;-(x\<^sup>T;1) \ -(x\<^sup>T \ 1')" + by (simp add: rtc_inductl) + hence "x\<^sup>T \ 1' \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1) = 0" + by (simp add: compl_le_swap1 galois_aux) + hence "x\<^sup>T \ 1' = 0" + using assms backward_terminating_iff3 inf.order_iff le_infI1 by blast + hence "x \ 1' = 0" + by (simp add: conv_self_conjugate) + thus ?thesis + by (simp add: galois_aux) +qed + +lemma forward_terminating_path_end_points_1: + assumes "forward_terminating_path x" + shows "x \ x\<^sup>+;end_points x" +proof - + have 1: "-(x;1) \ x = 0" + by (simp add: galois_aux maddux_20) + have "x = x\<^sup>\;-(x;1) \ x" + using assms forward_terminating_iff3 inf.absorb2 by fastforce + also have "... = (x\<^sup>+;-(x;1) + 1';-(x;1)) \ x" + by (simp add: sup.commute) + also have "... = x\<^sup>+;-(x;1) \ x + -(x;1) \ x" + using inf_sup_distrib2 by fastforce + also have "... = x\<^sup>+;-(x;1) \ x" + using 1 by simp + also have "... \ x\<^sup>+;(-(x;1) \ (x\<^sup>+)\<^sup>T;x)" + using modular_1_var by blast + also have "... = x\<^sup>+;(-(x;1) \ x\<^sup>T\<^sup>+;x)" + using plus_conv by fastforce + also have "... \ x\<^sup>+;end_points x" + by (metis inf_commute inf_top_right modular_1' mult_subdistl plus_conv plus_top) + finally show ?thesis . +qed + +lemma forward_terminating_path_end_points_2: + assumes "forward_terminating_path x" + shows "x\<^sup>T \ x\<^sup>\;end_points x" +proof - + have "x\<^sup>T \ x\<^sup>T;x;x\<^sup>T" + by (metis conv_invol x_leq_triple_x) + also have "... \ x\<^sup>T;x;1" + using mult_isol top_greatest by blast + also have "... \ x\<^sup>T;x\<^sup>+;end_points x;1" + by (metis assms forward_terminating_path_end_points_1 comp_assoc mult_isol mult_isor) + also have "... = x\<^sup>T;x\<^sup>+;end_points x" + by (metis inf_commute mult_assoc one_compl ra_1) + also have "... \ x\<^sup>\;end_points x" + by (metis assms comp_assoc compl_le_swap1 conv_galois_1 conv_invol p_fun_compl path_def) + finally show ?thesis . +qed + +lemma forward_terminating_path_end_points_3: + assumes "forward_terminating_path x" + shows "start_points x \ x\<^sup>+;end_points x" +proof - + have "start_points x \ x\<^sup>+;end_points x;1" + using assms forward_terminating_path_end_points_1 comp_assoc mult_isor inf.coboundedI1 + by blast + also have "... = x\<^sup>+;end_points x" + by (metis inf_commute mult_assoc one_compl ra_1 ) + finally show ?thesis . +qed + +lemma backward_terminating_path_start_points_1: + assumes "backward_terminating_path x" + shows "x\<^sup>T \ x\<^sup>T\<^sup>+;start_points x" +using assms forward_terminating_path_end_points_1 conv_backward_terminating_path by fastforce + +lemma backward_terminating_path_start_points_2: + assumes "backward_terminating_path x" + shows "x \ x\<^sup>T\<^sup>\;start_points x" +using assms forward_terminating_path_end_points_2 conv_backward_terminating_path by fastforce + +lemma backward_terminating_path_start_points_3: + assumes "backward_terminating_path x" + shows "end_points x \ x\<^sup>T\<^sup>+;start_points x" +using assms forward_terminating_path_end_points_3 conv_backward_terminating_path by fastforce + +(* lemma not shown in the paper; not necessary for other theorems *) +lemma path_aux1a: + assumes "forward_terminating_path x" + shows "x \ 0 \ end_points x \ 0" +using assms end_point_iff2 forward_terminating_iff1 end_point_iff1 galois_aux2 by force + +(* lemma not shown in the paper; not necessary for other theorems *) +lemma path_aux1b: + assumes "backward_terminating_path y" + shows "y \ 0 \ start_points y \ 0" +using assms start_point_iff2 backward_terminating_iff1 start_point_iff1 galois_aux2 by force + +(* lemma not shown in the paper; not necessary for other theorems *) +lemma path_aux1: + assumes "forward_terminating_path x" + and "backward_terminating_path y" + shows "x \ 0 \ y \ 0 \ end_points x \ 0 \ start_points y \ 0" +using assms path_aux1a path_aux1b by blast + +text \Equivalences for \finite\\ + +lemma backward_finite_iff_msc: + "backward_finite x \ many_strongly_connected x \ backward_terminating x" +proof + assume 1: "backward_finite x" + thus "many_strongly_connected x \ backward_terminating x" + proof (cases "-(1;x);x;1 = 0") + assume "-(1;x);x;1 = 0" + thus "many_strongly_connected x \ backward_terminating x" + using 1 by (metis conv_invol many_strongly_connected_iff_1 sup_bot_right) + next + assume "-(1;x);x;1 \ 0" + hence "1;-(1;x);x;1 = 1" + by (simp add: comp_assoc tarski) + hence "-(1;x);x;1 = 1" + by (metis comp_assoc conv_compl conv_contrav conv_invol conv_one one_compl) + thus "many_strongly_connected x \ backward_terminating x" + using 1 by simp + qed +next + assume "many_strongly_connected x \ backward_terminating x" + thus "backward_finite x" + by (metis star_ext sup.coboundedI1 sup.coboundedI2) +qed + +lemma forward_finite_iff_msc: + "forward_finite x \ many_strongly_connected x \ forward_terminating x" +by (metis backward_finite_iff_msc conv_backward_finite conv_backward_terminating conv_invol) + +lemma finite_iff_msc: + "finite x \ many_strongly_connected x \ terminating x" +using backward_finite_iff_msc forward_finite_iff_msc finite_iff by fastforce + +text \Path concatenation\ + +lemma path_concatenation: + assumes "forward_terminating_path x" + and "backward_terminating_path y" + and "end_points x = start_points y" + and "x;1 \ (x\<^sup>T;1 + y;1) \ y\<^sup>T;1 = 0" + shows "path (x+y)" +proof (cases "y = 0") + assume "y = 0" + thus ?thesis + using assms(1) by fastforce +next + assume as: "y \ 0" + show ?thesis + proof (unfold path_def; intro conjI) + from assms(4) have a: "x;1 \ x\<^sup>T;1 \ y\<^sup>T;1 + x;1 \ y;1 \ y\<^sup>T;1= 0" + by (simp add: inf_sup_distrib1 inf_sup_distrib2) + hence aux1: "x;1 \ x\<^sup>T;1 \ y\<^sup>T;1 = 0" + using sup_eq_bot_iff by blast + from a have aux2: "x;1 \ y;1 \ y\<^sup>T;1= 0" + using sup_eq_bot_iff by blast + + show "is_inj (x + y)" + proof (unfold is_inj_def; auto simp add: distrib_left) + show "x;x\<^sup>T \ 1'" + using assms(1) path_def is_inj_def by blast + show "y;y\<^sup>T \ 1'" + using assms(2) path_def is_inj_def by blast + have "y;x\<^sup>T = 0" + by (metis assms(3) aux1 annir comp_assoc conv_one le_bot modular_var_2 one_idem_mult + path_concat_aux_2 schroeder_2) + thus "y;x\<^sup>T \ 1'" + using bot_least le_bot by blast + thus "x;y\<^sup>T \ 1'" + using conv_iso by force + qed + + show "is_p_fun (x + y)" + proof (unfold is_p_fun_def; auto simp add: distrib_left) + show "x\<^sup>T;x \ 1'" + using assms(1) path_def is_p_fun_def by blast + show "y\<^sup>T;y \ 1'" + using assms(2) path_def is_p_fun_def by blast + have "y\<^sup>T;x \ y\<^sup>T;(y;1 \ x;1)" + by (metis conjugation_prop2 inf.commute inf_top.left_neutral maddux_20 mult_isol order_trans + schroeder_1_var) + also have "... = 0" + using assms(3) aux2 annir inf_commute path_concat_aux_1 by fastforce + finally show "y\<^sup>T;x \ 1'" + using bot_least le_bot by blast + thus "x\<^sup>T;y \ 1'" + using conv_iso by force + qed + + show "connected (x + y)" + proof (auto simp add: distrib_left) + have "x;1;x \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using assms(1) path_def by simp + also have "... \ (x\<^sup>\;y\<^sup>\)\<^sup>\ + (x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\)\<^sup>\" + using join_iso join_isol star_subdist by simp + finally show "x;1;x \ (x\<^sup>\;y\<^sup>\)\<^sup>\ + (x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\)\<^sup>\" . + have "y;1;y \ y\<^sup>\ + y\<^sup>T\<^sup>\" + using assms(2) path_def by simp + also have "... \ (x\<^sup>\;y\<^sup>\)\<^sup>\ + (x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\)\<^sup>\" + by (metis star_denest star_subdist sup.mono sup_commute) + finally show "y;1;y \ (x\<^sup>\;y\<^sup>\)\<^sup>\ + (x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\)\<^sup>\" . + + show "y;1;x \ (x\<^sup>\;y\<^sup>\)\<^sup>\ + (x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\)\<^sup>\" + proof - + have "(y;1);1;(1;x) \ y\<^sup>T\<^sup>\;x\<^sup>T\<^sup>\" + proof (rule_tac v="start_points y" in path_concat_aux_0) + show "is_vector (start_points y)" + by (metis is_vector_def comp_assoc one_compl one_idem_mult ra_1) + show "start_points y \ 0" + using as + by (metis assms(2) conv_compl conv_contrav conv_one inf.orderE inf_bot_right + inf_top.right_neutral maddux_141) + have "(start_points y);1;y\<^sup>T \ y\<^sup>\" + by (rule path_concat_aux_5) (simp_all add: assms(2)) + thus "y;1;(start_points y)\<^sup>T \ y\<^sup>T\<^sup>\" + by (metis (mono_tags, lifting) conv_iso comp_assoc conv_contrav conv_invol conv_one + star_conv) + have "end_points x;1;x \ x\<^sup>T\<^sup>\" + apply (rule path_concat_aux_5) + using assms(1) conv_path by simp_all + thus "start_points y;(1;x) \ x\<^sup>T\<^sup>\" + by (metis assms(3) mult_assoc) + qed + thus ?thesis + by (metis comp_assoc le_supI2 less_eq_def one_idem_mult star_denest star_subdist_var_1 + sup.commute) + qed + + show "x;1;y \ (x\<^sup>\;y\<^sup>\)\<^sup>\ + (x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\)\<^sup>\" + proof - + have "(x;1);1;(1;y) \ x\<^sup>\;y\<^sup>\" + proof (rule_tac v="start_points y" in path_concat_aux_0) + show "is_vector (start_points y)" + by (simp add: comp_assoc is_vector_def one_compl vector_1_comm) + show "start_points y \ 0" + using as assms(2,4) backward_terminating_iff1 galois_aux2 start_point_iff1 start_point_iff2 + by blast + have "end_points x;1;x\<^sup>T \ x\<^sup>T\<^sup>\" + apply (rule path_concat_aux_5) + using assms(1) conv_path by simp_all + hence "(end_points x;1;x\<^sup>T)\<^sup>T \ (x\<^sup>T\<^sup>\)\<^sup>T" + using conv_iso by blast + thus "x;1;(start_points y)\<^sup>T \ x\<^sup>\" + by (simp add: assms(3) comp_assoc star_conv) + have "start_points y;1;y \ y\<^sup>\" + by (rule path_concat_aux_5) (simp_all add: assms(2)) + thus "start_points y;(1;y) \ y\<^sup>\" + by (simp add: mult_assoc) + qed + thus ?thesis + by (metis comp_assoc dual_order.trans le_supI1 one_idem_mult star_ext) + qed + qed + qed +qed + +lemma path_concatenation_with_edge: + assumes "x\0" + and "forward_terminating_path x" + and "is_point q" + and "q \ -(1;x)" + shows "path (x+(end_points x);q\<^sup>T)" +proof (rule path_concatenation) + from assms(1,2) have 1: "is_point(end_points x)" + using end_point_zero_point path_aux1a by blast + show 2: "backward_terminating_path ((end_points x);q\<^sup>T)" + apply (intro conjI) + apply (metis edge_is_path 1 assms(3)) + by (metis assms(2-4) 1 bot_least comp_assoc compl_le_swap1 conv_galois_2 double_compl + end_point_iff1 le_supE point_equations(1) tarski top_le) + thus "end_points x = start_points ((end_points x);q\<^sup>T)" + by (metis assms(3) 1 edge_start comp_assoc compl_top_eq double_compl inf.absorb_iff2 inf.commute + inf_top_right modular_2_aux' point_equations(2)) + show "x;1 \ (x\<^sup>T;1 + ((end_points x);q\<^sup>T);1) \ ((end_points x);q\<^sup>T)\<^sup>T;1 = 0" + using 2 by (metis assms(3,4) annir compl_le_swap1 compl_top_eq conv_galois_2 double_compl + inf.absorb_iff2 inf.commute modular_1' modular_2_aux' point_equations(2)) + show "forward_terminating_path x" + by (simp add: assms(2)) +qed + +lemma path_concatenation_cycle_free: + assumes "forward_terminating_path x" + and "backward_terminating_path y" + and "end_points x = start_points y" + and "x;1 \ y\<^sup>T;1 = 0" + shows "path (x+y)" +apply (rule path_concatenation,simp_all add: assms) +by (metis assms(4) inf.left_commute inf_bot_right inf_commute) + +lemma path_concatenation_start_points_approx: + assumes "end_points x = start_points y" + shows "start_points (x+y) \ start_points x" +proof - + have "start_points (x+y) = x;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1) + y;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1)" + by (simp add: inf.assoc inf_sup_distrib2) + also with assms(1) have "... = x;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1) + x\<^sup>T;1 \ -(x\<^sup>T;1) \ -(x;1)" + by (metis inf.assoc inf.left_commute) + also have "... = x;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1)" + by simp + also have "... \ start_points x" + using inf_le1 by blast + finally show ?thesis . +qed + +lemma path_concatenation_end_points_approx: + assumes "end_points x = start_points y" + shows "end_points (x+y) \ end_points y" +proof - + have "end_points (x+y) = x\<^sup>T;1 \ -(x;1) \ -(y;1) + y\<^sup>T;1 \ -(x;1) \ -(y;1)" + by (simp add: inf.assoc inf_sup_distrib2) + also from assms(1) have "... = y;1 \ -(y\<^sup>T;1) \ -(y;1) + y\<^sup>T;1 \ -(x;1) \ -(y;1)" + by simp + also have "... = y\<^sup>T;1 \ -(x;1) \ -(y;1)" + by (simp add: inf.commute) + also have "... \ end_points y" + using inf_le1 meet_iso by blast + finally show ?thesis . +qed + +lemma path_concatenation_start_points: + assumes "end_points x = start_points y" + and "x;1 \ y\<^sup>T;1 = 0" + shows "start_points (x+y) = start_points x" +proof - + from assms(2) have aux: "x;1 \ -(y\<^sup>T;1) = x;1" + by (simp add: galois_aux inf.absorb1) + + have "start_points (x+y) = (x;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1)) + (y;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1))" + by (simp add: inf_sup_distrib2 inf.assoc) + also from assms(1) have "... = (x;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1)) + (x\<^sup>T;1 \ -(x;1) \ -(x\<^sup>T;1))" + using inf.assoc inf.commute by simp + also have "... = (x;1 \ -(x\<^sup>T;1) \ -(y\<^sup>T;1))" + by (simp add: inf.assoc) + also from aux have "... = x;1 \ -(x\<^sup>T;1)" + by (metis inf.assoc inf.commute) + finally show ?thesis . +qed + +lemma path_concatenation_end_points: + assumes "end_points x = start_points y" + and "x;1 \ y\<^sup>T;1 = 0" + shows "end_points (x+y) = end_points y" +proof - + from assms(2) have aux: "y\<^sup>T;1 \ -(x;1) = y\<^sup>T;1" + using galois_aux inf.absorb1 inf_commute by blast + + have "end_points (x+y) = (x\<^sup>T;1 + y\<^sup>T;1) \ -(x;1) \ -(y;1)" + using inf.assoc by simp + also from assms(1) have "... = (y;1 \ -(y\<^sup>T;1) \ -(y;1)) + (y\<^sup>T;1 \ -(x;1) \ -(y;1))" + by (simp add: inf_sup_distrib2) + also have "... = y\<^sup>T;1 \ -(x;1) \ -(y;1)" + by (simp add: inf.assoc) + also from aux have "... = y\<^sup>T;1 \ -(y;1)" + by (metis inf.assoc inf.commute) + finally show ?thesis . +qed + +lemma path_concatenation_cycle_free_complete: + assumes "forward_terminating_path x" + and "backward_terminating_path y" + and "end_points x = start_points y" + and "x;1 \ y\<^sup>T;1 = 0" + shows "path (x+y) \ start_points (x+y) = start_points x \ end_points (x+y) = end_points y" +using assms path_concatenation_cycle_free path_concatenation_end_points path_concatenation_start_points +by blast + +text \Path restriction (path from a given point)\ + +lemma reachable_points_iff: + assumes "point p" + shows "(x\<^sup>T\<^sup>\;p \ x) = (x\<^sup>T\<^sup>\;p \ 1');x" +proof (rule antisym) + show "(x\<^sup>T\<^sup>\;p \ 1');x \ x\<^sup>T\<^sup>\;p \ x" + proof (rule le_infI) + show "(x\<^sup>T\<^sup>\;p \ 1');x \ x\<^sup>T\<^sup>\;p" + proof - + have "(x\<^sup>T\<^sup>\;p \ 1');x \ x\<^sup>T\<^sup>\;p;1" + by (simp add: mult_isol_var) + also have "... \ x\<^sup>T\<^sup>\;p" + using assms by (simp add: comp_assoc eq_iff point_equations(1) point_is_point) + finally show ?thesis . + qed + show "(x\<^sup>T\<^sup>\;p \ 1');x \ x" + by (metis inf_le2 mult_isor mult_onel) + qed + show "x\<^sup>T\<^sup>\;p \ x \ (x\<^sup>T\<^sup>\;p \ 1');x" + proof - + have "(x\<^sup>T\<^sup>\;p);x\<^sup>T \ x\<^sup>T\<^sup>\;p + -1'" + by (metis assms comp_assoc is_vector_def mult_isol point_def sup.coboundedI1 top_greatest) + hence aux: "(-(x\<^sup>T\<^sup>\;p) \ 1');x \ -(x\<^sup>T\<^sup>\;p)" + using compl_mono conv_galois_2 by fastforce + have "x = (x\<^sup>T\<^sup>\;p \ 1');x + (-(x\<^sup>T\<^sup>\;p) \ 1');x" + by (metis aux4 distrib_right inf_commute mult_1_left) + also with aux have "... \ (x\<^sup>T\<^sup>\;p \ 1');x + -(x\<^sup>T\<^sup>\;p)" + using join_isol by blast + finally have "x \ (x\<^sup>T\<^sup>\;p \ 1');x + -(x\<^sup>T\<^sup>\;p)" . + thus ?thesis + using galois_2 inf.commute by fastforce + qed +qed + +lemma path_from_given_point: + assumes "path x" + and "point p" + shows "path(x\<^sup>T\<^sup>\;p \ x)" + and "start_points(x\<^sup>T\<^sup>\;p \ x) \ p" + and "end_points(x\<^sup>T\<^sup>\;p \ x) \ end_points(x)" +proof (unfold path_def; intro conjI) + show uni: "is_p_fun (x\<^sup>T\<^sup>\;p \ x)" + by (metis assms(1) inf_commute is_p_fun_def p_fun_mult_var path_def) + show inj: "is_inj (x\<^sup>T\<^sup>\;p \ x)" + by (metis abel_semigroup.commute assms(1) conv_times inf.abel_semigroup_axioms inj_p_fun + is_p_fun_def p_fun_mult_var path_def) + show "connected (x\<^sup>T\<^sup>\;p \ x)" + proof - + let ?t="x\<^sup>T\<^sup>\;p \ 1'" + let ?u="-(x\<^sup>T\<^sup>\;p) \ 1'" + (* some aux statements about ?t and ?u *) + have t_plus_u: "?t + ?u = 1'" + by (simp add: inf.commute) + have t_times_u: "?t ; ?u \ 0" + by (simp add: inf.left_commute is_test_def test_comp_eq_mult) + have t_conv: "?t\<^sup>T=?t" + using inf.cobounded2 is_test_def test_eq_conv by blast + have txu_zero: "?t;x;?u \ 0" + proof - + have "x\<^sup>T;?t;1 \ -?u" + proof - + have "x\<^sup>T;?t;1 \ x\<^sup>T;x\<^sup>T\<^sup>\;p" + using assms(2) + by (simp add: is_vector_def mult.semigroup_axioms mult_isol_var mult_subdistr order.refl + point_def semigroup.assoc) + also have "... \ -?u" + by (simp add: le_supI1 mult_isor) + finally show ?thesis . + qed + thus ?thesis + by (metis compl_bot_eq compl_le_swap1 conv_contrav conv_galois_1 t_conv) + qed + hence txux_zero: "?t;x;?u;x \ 0" + using annil le_bot by fastforce + (* end some aux statements about ?t and ?u *) + + have tx_leq: "?t;x\<^sup>\ \ (?t;x)\<^sup>\" + proof - + have "?t;x\<^sup>\ = ?t;(?t;x + ?u;x)\<^sup>\" + using t_plus_u by (metis distrib_right' mult_onel) + also have "... = ?t;(?u;x;(?u;x)\<^sup>\;(?t;x)\<^sup>\+(?t;x)\<^sup>\)" + using txux_zero star_denest_10 by (simp add: comp_assoc le_bot) + also have "... = ?t;?u;x;(?u;x)\<^sup>\;(?t;x)\<^sup>\+?t;(?t;x)\<^sup>\" + by (simp add: comp_assoc distrib_left) + also have "... \ 0;x;(?u;x)\<^sup>\;(?t;x)\<^sup>\+?t;(?t;x)\<^sup>\" + using le_bot t_times_u by blast + also have "... \(?t;x)\<^sup>\" + by (metis annil inf.commute inf_bot_right le_supI mult_onel mult_subdistr) + finally show ?thesis . + qed + + hence aux: "?t;x\<^sup>\;?t \ (?t;x)\<^sup>\" + using inf.cobounded2 order.trans prod_star_closure star_ref by blast + with t_conv have aux_trans: "?t;x\<^sup>T\<^sup>\;?t \ (?t;x)\<^sup>T\<^sup>\" + by (metis comp_assoc conv_contrav conv_self_conjugate_var g_iso star_conv) + + from aux aux_trans have "?t;(x\<^sup>\+x\<^sup>T\<^sup>\);?t \ (?t;x)\<^sup>\ + (?t;x)\<^sup>T\<^sup>\" + by (metis sup_mono distrib_right' distrib_left) + with assms(1) path_concat_aux3_1 have "?t;(x;1;x\<^sup>T);?t \ (?t;x)\<^sup>\ + (?t;x)\<^sup>T\<^sup>\" + using dual_order.trans mult_double_iso by blast + with t_conv have "(?t;x);1;(?t;x)\<^sup>T \ (?t;x)\<^sup>\ + (?t;x)\<^sup>T\<^sup>\" + using comp_assoc conv_contrav by fastforce + with connected_iff2 show ?thesis + using assms(2) inj reachable_points_iff uni by fastforce + qed +next + show "start_points (x\<^sup>T\<^sup>\;p \ x) \ p" + proof - + have 1: "is_vector (x\<^sup>T\<^sup>\;p)" + using assms(2) by (simp add: is_vector_def mult_assoc point_def) + hence "(x\<^sup>T\<^sup>\;p \ x);1 \ x\<^sup>T\<^sup>\;p" + by (simp add: inf.commute vector_1_comm) + also have "... = x\<^sup>T\<^sup>+;p + p" + by (simp add: sup.commute) + finally have 2: "(x\<^sup>T\<^sup>\;p \ x);1 \ -(x\<^sup>T\<^sup>+;p) \ p" + using galois_1 by blast + have "(x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 = (x\<^sup>T \ (x\<^sup>T\<^sup>\;p)\<^sup>T);1" + by (simp add: inf.commute) + also have "... = x\<^sup>T;(x\<^sup>T\<^sup>\;p \ 1)" + using 1 vector_2 by blast + also have "... = x\<^sup>T\<^sup>+;p" + by (simp add: comp_assoc) + finally show "start_points (x\<^sup>T\<^sup>\;p \ x) \ p" + using 2 by simp + qed +next + show "end_points(x\<^sup>T\<^sup>\;p \ x) \ end_points(x)" + proof - + have 1: "is_vector (x\<^sup>T\<^sup>\;p)" + using assms(2) by (simp add: is_vector_def mult_assoc point_def) + have "(x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 = ((x\<^sup>T\<^sup>\;p)\<^sup>T \ x\<^sup>T);1" + by (simp add: star_conv) + also have "... = x\<^sup>T;(x\<^sup>T\<^sup>\;p \ 1)" + using 1 vector_2 inf.commute by fastforce + also have "... \ x\<^sup>T\<^sup>\;p" + using comp_assoc mult_isor by fastforce + finally have 2: "(x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 \ -(x\<^sup>T\<^sup>\;p) = 0" + using galois_aux2 by blast + have "(x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 \ -((x\<^sup>T\<^sup>\;p \ x);1) = (x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 \ (-(x\<^sup>T\<^sup>\;p) + -(x;1))" + using 1 vector_1 by fastforce + also have "... = (x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 \ -(x\<^sup>T\<^sup>\;p) + (x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 \ -(x;1)" + using inf_sup_distrib1 by blast + also have "... = (x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 \ -(x;1)" + using 2 by simp + also have "... \ x\<^sup>T;1 \ -(x;1)" + using meet_iso mult_subdistr_var by fastforce + finally show ?thesis . + qed +qed + +lemma path_from_given_point': + assumes "has_start_points_path x" + and "point p" + and "p \ x;1" (* p has a successor hence path not empty *) + shows "path(x\<^sup>T\<^sup>\;p \ x)" + and "start_points(x\<^sup>T\<^sup>\;p \ x) = p" + and "end_points(x\<^sup>T\<^sup>\;p \ x) = end_points(x)" +proof - + show "path(x\<^sup>T\<^sup>\;p \ x)" + using assms path_from_given_point(1) by blast +next + show "start_points(x\<^sup>T\<^sup>\;p \ x) = p" + proof (simp only: eq_iff; rule conjI) + show "start_points(x\<^sup>T\<^sup>\;p \ x) \ p" + using assms path_from_given_point(2) by blast + show "p \ start_points(x\<^sup>T\<^sup>\;p \ x)" + proof - + have 1: "is_vector(x\<^sup>T\<^sup>\;p)" + using assms(2) comp_assoc is_vector_def point_equations(1) point_is_point by fastforce + hence a: "p \ (x\<^sup>T\<^sup>\;p \ x);1" + by (metis vector_1 assms(3) conway.dagger_unfoldl_distr inf.orderI inf_greatest + inf_sup_absorb) + + have "x\<^sup>T\<^sup>+;p \ p \ (x\<^sup>T\<^sup>+ \ 1'); p" + using assms(2) inj_distr point_def by fastforce + also have "... \ (-1'\<^sup>T \ 1'); p" + using assms(1) path_acyclic + by (metis conv_contrav conv_e meet_iso mult_isor star_conv star_slide_var test_converse) + also have "... \ 0" + by simp + finally have 2: "x\<^sup>T\<^sup>+;p \ p \ 0" . + + have b: "p \ -((x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1)" + proof - + have "(x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1 = ((x\<^sup>T\<^sup>\;p)\<^sup>T \ x\<^sup>T);1" + by (simp add: star_conv) + also have "... = x\<^sup>T;(x\<^sup>T\<^sup>\;p \ 1)" + using 1 vector_2 inf.commute by fastforce + also have "... = x\<^sup>T;x\<^sup>T\<^sup>\;p" + by (simp add: comp_assoc) + also have "... \ -p" + using 2 galois_aux le_bot by blast + finally show ?thesis + using compl_le_swap1 by blast + qed + with a show ?thesis + by simp + qed + qed +next + show "end_points(x\<^sup>T\<^sup>\;p \ x) = end_points(x)" + proof (simp only: eq_iff; rule conjI) + show "end_points(x\<^sup>T\<^sup>\;p \ x) \ end_points(x)" + using assms path_from_given_point(3) by blast + show "end_points(x) \ end_points(x\<^sup>T\<^sup>\;p \ x)" + proof - + have 1: "is_vector(x\<^sup>T\<^sup>\;p)" + using assms(2) comp_assoc is_vector_def point_equations(1) point_is_point by fastforce + have 2: "is_vector(end_points(x))" + by (simp add: comp_assoc is_vector_def one_compl vector_1_comm) + have a: "end_points(x) \ (x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1" + proof - + have "x\<^sup>T;1 \ 1;x\<^sup>T = x\<^sup>T;1;x\<^sup>T" + by (simp add: vector_meet_comp_x') + also have "... \ x\<^sup>T\<^sup>\ + x\<^sup>\" + using assms(1) path_concat_aux3_3 sup.commute by fastforce + also have "... = x\<^sup>T\<^sup>\ + x\<^sup>+" + by (simp add: star_star_plus sup.commute) + also have "... \ x\<^sup>T\<^sup>\ + x;1" + using join_isol mult_isol by fastforce + finally have "end_points(x) \ 1;x\<^sup>T \ x\<^sup>T\<^sup>\" + by (metis galois_1 inf.assoc inf.commute sup_commute) + hence "end_points(x) \ p\<^sup>T \ x\<^sup>T\<^sup>\" + using assms(3) + by (metis conv_contrav conv_iso conv_one dual_order.trans inf.cobounded1 inf.right_idem + inf_mono) + hence "end_points(x) ; p\<^sup>T \ x\<^sup>T\<^sup>\" + using assms(2) 2 by (simp add: point_def vector_meet_comp) + hence "end_points(x) \ x\<^sup>T\<^sup>\;p" + using assms(2) point_def ss423bij by blast + hence "x\<^sup>T;1 \ x\<^sup>T\<^sup>\;p + x;1" + by (simp add: galois_1 sup_commute) + hence "x\<^sup>T;1 \ x\<^sup>T\<^sup>+;p + p + x;1" + by (metis conway.dagger_unfoldl_distr sup_commute) + hence "x\<^sup>T;1 \ x\<^sup>T\<^sup>+;p + x;1" + by (simp add: assms(3) sup.absorb2 sup.assoc) + hence "end_points(x) \ x\<^sup>T\<^sup>+;p" + by (simp add: galois_1 sup_commute) + also have "... = (x\<^sup>T\<^sup>\;p \ x)\<^sup>T;1" + using 1 inf_commute mult_assoc vector_2 by fastforce + finally show ?thesis . + qed + have "x\<^sup>T;1 \ (x\<^sup>T\<^sup>\;p \ x);1 \ x;1" + by (simp add: le_infI2 mult_isor) + hence b: "end_points(x) \ -((x\<^sup>T\<^sup>\;p \ x);1)" + using galois_1 galois_2 by blast + with a show ?thesis + by simp + qed + qed +qed + +text \Cycles\ + +lemma selfloop_is_cycle: + assumes "is_point x" + shows "cycle (x;x\<^sup>T)" + by (simp add: assms edge_is_path) + +lemma start_point_no_cycle: + assumes "has_start_points_path x" + shows "\ cycle x" +using assms many_strongly_connected_implies_no_start_end_points no_start_end_points_iff + start_point_iff1 start_point_iff2 by blast + +lemma end_point_no_cycle: + assumes "has_end_points_path x" + shows "\ cycle x" +using assms end_point_iff2 end_point_iff1 many_strongly_connected_implies_no_start_end_points + no_start_end_points_iff by blast + +lemma cycle_no_points: + assumes "cycle x" + shows "start_points x = 0" + and "end_points x = 0" + by (metis assms inf_compl_bot many_strongly_connected_implies_no_start_end_points)+ + +text \Path concatenation to cycle\ + +lemma path_path_equals_cycle_aux: + assumes "has_start_end_points_path x" + and "has_start_end_points_path y" + and "start_points x = end_points y" + and "end_points x = start_points y" +shows "x \ (x+y)\<^sup>T\<^sup>\" +proof- + let ?e = "end_points(x)" + let ?s = "start_points(x)" + have sp: "is_point(?s)" + using assms(1) start_point_iff2 has_start_end_points_path_iff by blast + have ep: "is_point(?e)" + using assms(1) end_point_iff2 has_start_end_points_path_iff by blast + + have "x \ x\<^sup>T\<^sup>\;?s;1 \ 1;?e\<^sup>T;x\<^sup>T\<^sup>\" + by (metis assms(1) backward_terminating_path_start_points_2 end_point_iff2 ep + forward_terminating_iff1 forward_terminating_path_end_points_2 comp_assoc + conv_contrav conv_invol conv_iso inf.boundedI point_equations(1) point_equations(4) + star_conv sp start_point_iff2) + also have "... = x\<^sup>T\<^sup>\;?s;1;?e\<^sup>T;x\<^sup>T\<^sup>\" + by (metis inf_commute inf_top_right ra_1) + also have "... = x\<^sup>T\<^sup>\;?s;?e\<^sup>T;x\<^sup>T\<^sup>\" + by (metis ep comp_assoc point_equations(4)) + also have "... \ x\<^sup>T\<^sup>\;y\<^sup>T\<^sup>\;x\<^sup>T\<^sup>\" + by (metis (mono_tags, lifting) assms(2-4) start_to_end comp_assoc conv_contrav conv_invol + conv_iso mult_double_iso star_conv) + also have "... = (x\<^sup>\;y\<^sup>\;x\<^sup>\)\<^sup>T" + by (simp add: comp_assoc star_conv) + also have "... \ ((x+y)\<^sup>\;(x+y)\<^sup>\;(x+y)\<^sup>\)\<^sup>T" + by (metis conv_invol conv_iso prod_star_closure star_conv star_denest star_ext star_iso + star_trans_eq sup_ge1) + also have "... = (x+y)\<^sup>T\<^sup>\" + by (metis star_conv star_trans_eq) + finally show x: "x \ (x+y)\<^sup>T\<^sup>\" . + qed + +lemma path_path_equals_cycle: + assumes "has_start_end_points_path x" + and "has_start_end_points_path y" + and "start_points x = end_points y" + and "end_points x = start_points y" + and "x;1 \ (x\<^sup>T;1 + y;1) \ y\<^sup>T;1 = 0" + shows "cycle(x + y)" +proof (intro conjI) + show "path (x + y)" + apply (rule path_concatenation) + using assms by(simp_all add:has_start_end_points_iff) + show "many_strongly_connected (x + y)" + by (metis path_path_equals_cycle_aux assms(1-4) sup.commute le_supI many_strongly_connected_iff_3) +qed + +lemma path_edge_equals_cycle: + assumes "has_start_end_points_path x" + shows "cycle(x + end_points(x);(start_points x)\<^sup>T)" +proof (rule path_path_equals_cycle) + let ?s = "start_points x" + let ?e = "end_points x" + let ?y = "(?e;?s\<^sup>T)" + + have sp: "is_point(?s)" + using start_point_iff2 assms has_start_end_points_path_iff by blast + have ep: "is_point(?e)" + using end_point_iff2 assms has_start_end_points_path_iff by blast + + show "has_start_end_points_path x" + using assms by blast + show "has_start_end_points_path ?y" + using edge_is_path + by (metis assms edge_end edge_start end_point_iff2 end_point_iff1 galois_aux2 + has_start_end_points_iff inf.left_idem inf_compl_bot_right start_point_iff2) + show "?s = end_points ?y" + by (metis sp ep edge_end annil conv_zero inf.left_idem inf_compl_bot_right) + thus "?e = start_points ?y" + by (metis edge_start ep conv_contrav conv_invol sp) + show "x;1 \ (x\<^sup>T;1 + ?e;?s\<^sup>T;1) \ (?e;?s\<^sup>T)\<^sup>T;1 = 0" + proof - + have "x;1 \ (x\<^sup>T;1 + ?e;?s\<^sup>T;1) \ (?e;?s\<^sup>T)\<^sup>T;1 = x;1 \ (x\<^sup>T;1 + ?e;1;?s\<^sup>T;1) \ (?s;?e\<^sup>T);1" + using sp comp_assoc point_equations(3) by fastforce + also have "... = x;1 \ (x\<^sup>T;1 + ?e;1) \ ?s;1" + by (metis sp ep comp_assoc point_equations(1,3)) + also have "... \ 0" + by (simp add: sp ep inf.assoc point_equations(1)) + finally show ?thesis + using bot_unique by blast + qed +qed + +text \Break cycles\ + +lemma cycle_remove_edge: + assumes "cycle x" + and "point s" + and "point e" + and "e;s\<^sup>T \ x" + shows "path(x \ -(e;s\<^sup>T))" + and "start_points (x \ -(e;s\<^sup>T)) \ s" + and "end_points (x \ -(e;s\<^sup>T)) \ e" +proof - + show "path(x \ -(e;s\<^sup>T))" + proof (unfold path_def; intro conjI) + show 1: "is_p_fun(x \ -(e;s\<^sup>T))" + using assms(1) path_def is_p_fun_def p_fun_mult_var by blast + show 2: "is_inj(x \ -(e;s\<^sup>T))" + using assms(1) path_def inf.cobounded1 injective_down_closed by blast + show "connected (x \ -(e;s\<^sup>T))" + proof - + have "x\<^sup>\ = ((x \ -(e;s\<^sup>T)) + e;s\<^sup>T)\<^sup>\" + by (metis assms(4) aux4_comm inf.absorb2) + also have "... = (x \ -(e;s\<^sup>T))\<^sup>\ ; (e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\)\<^sup>\" + by simp + also have "... = (x \ -(e;s\<^sup>T))\<^sup>\ ; (1' + e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\;(e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\)\<^sup>\)" + by fastforce + also have "... = (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\;(e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\)\<^sup>\" + by (simp add: distrib_left mult_assoc) + also have "... = (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;(s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\;e)\<^sup>\;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\" + by (simp add: comp_assoc star_slide) + also have "... \ (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;1;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\" + using top_greatest join_isol mult_double_iso by (metis mult_assoc) + also have "... = (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\" + using assms(3) by (simp add: comp_assoc is_vector_def point_def) + finally have 3: "x\<^sup>\ \ (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\" . + + from assms(4) have "e;s\<^sup>T \ e;e\<^sup>T;x" + using assms(3) comp_assoc mult_isol point_def ss423conv by fastforce + also have "... \ e;e\<^sup>T;(x\<^sup>\)\<^sup>T" + using assms(1) many_strongly_connected_iff_3 mult_isol star_conv by fastforce + also have "... \ e;e\<^sup>T;((x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\)\<^sup>T" + using 3 conv_iso mult_isol by blast + also have "... \ e;e\<^sup>T;((x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ ; s;e\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\)" + by (simp add: star_conv comp_assoc) + also have "... \ e;e\<^sup>T;(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ + e;e\<^sup>T;(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ ; s;e\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + by (simp add: comp_assoc distrib_left) + also have "... \ e;e\<^sup>T;(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ + e;1;e\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + by (metis comp_assoc join_isol mult_isol mult_isor top_greatest) + also have "... \ e;e\<^sup>T;(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ + e;e\<^sup>T;(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + using assms(3) by (simp add: point_equations(1) point_is_point) + also have "... = e;e\<^sup>T;(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + by simp + also have "... \ 1';(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + using assms(3) is_inj_def point_def join_iso mult_isor by blast + finally have 4: "e;s\<^sup>T \(x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + by simp + + have "(x \ -(e;s\<^sup>T));1;(x \ -(e;s\<^sup>T)) \ x;1;x" + by (simp add: mult_isol_var) + also have "...\ x\<^sup>\" + using assms(1) connected_iff4 one_strongly_connected_iff one_strongly_connected_implies_8 + path_concat_aux3_3 by blast + also have "... \ (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; e;s\<^sup>T ; (x \ -(e;s\<^sup>T))\<^sup>\" + by (rule 3) + also have "... \ (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>\ ; (x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\ ; (x \ -(e;s\<^sup>T))\<^sup>\" + using 4 by (metis comp_assoc join_isol mult_isol mult_isor) + also have "... \ (x \ -(e;s\<^sup>T))\<^sup>\ + (x \ -(e;s\<^sup>T))\<^sup>T\<^sup>\" + using 1 2 triple_star by force + finally show ?thesis . + qed + qed +next + show "start_points (x \ -(e;s\<^sup>T)) \ s" + proof - + have 1: "is_vector(-s)" + using assms(2) by (simp add: point_def vector_compl) + have "(x \ -(e;s\<^sup>T));1 \ -s \ x;1 \ -s" + using meet_iso mult_subdistr by blast + also have "... \ x\<^sup>T;1 \ -s" + using assms(1) many_strongly_connected_implies_no_start_end_points meet_iso + no_start_end_points_path_iff by blast + also have "... \ (x\<^sup>T \ -s);1" + using 1 by (simp add: vector_1_comm) + also have "... \ (x\<^sup>T \ -(s;e\<^sup>T));1" + by (metis 1 galois_aux inf.boundedI inf.cobounded1 inf.commute mult_isor schroeder_2 + vector_1_comm) + also have "... = (x \ -(e;s\<^sup>T))\<^sup>T;1" + by (simp add: conv_compl) + finally show ?thesis + by (simp add: galois_1 sup_commute) + qed +next + show "end_points (x \ -(e;s\<^sup>T)) \ e" + proof - + have 1: "is_vector(-e)" + using assms(3) by (simp add: point_def vector_compl) + have "(x \ -(e;s\<^sup>T))\<^sup>T;1 \ -e \ x\<^sup>T;1 \ -e" + using meet_iso mult_subdistr by simp + also have "... \ x;1 \ -e" + using assms(1) many_strongly_connected_implies_no_start_end_points meet_iso + no_start_end_points_path_iff by blast + also have "... \ (x \ -e);1" + using 1 by (simp add: vector_1_comm) + also have "... \ (x \ -(e;s\<^sup>T));1" + by (metis 1 galois_aux inf.boundedI inf.cobounded1 inf.commute mult_isor schroeder_2 + vector_1_comm) + finally show ?thesis + by (simp add: galois_1 sup_commute) + qed +qed + +lemma cycle_remove_edge': + assumes "cycle x" + and "point s" + and "point e" + and "s\e" + and "e;s\<^sup>T \ x" + shows "path(x \ -(e;s\<^sup>T))" + and "s = start_points (x \ -(e;s\<^sup>T))" + and "e = end_points (x \ -(e;s\<^sup>T))" +proof - + show "path (x \ - (e ; s\<^sup>T))" + using assms(1,2,3,5) cycle_remove_edge(1) by blast +next + show "s = start_points (x \ - (e ; s\<^sup>T))" + proof (simp only: eq_iff; rule conjI) + show "s \ start_points (x \ - (e ; s\<^sup>T))" + proof - + have a: "s \ (x \ - (e ; s\<^sup>T));1" + proof - + have 1: "is_vector(-e)" + using assms(3) point_def vector_compl by blast + from assms(2-4) have "s = s \ -e" + using comp_assoc edge_end point_equations(1) point_equations(3) point_is_point by fastforce + also have "... \ x\<^sup>T;e \ -e" + using assms(3,5) conv_iso meet_iso point_def ss423conv by fastforce + also have "... \ x;1 \ -e" + by (metis assms(1) many_strongly_connected_implies_no_start_end_points meet_iso mult_isol + top_greatest) + also have "... \ (x \ -e);1" + using 1 by (simp add: vector_1_comm) + also have "... \ (x \ - (e ; s\<^sup>T));1" + by (metis assms(3) comp_anti is_vector_def meet_isor mult_isol mult_isor point_def + top_greatest) + finally show ?thesis . + qed + have b: "s \ -((x \ - (e ; s\<^sup>T))\<^sup>T;1)" + proof - + have 1: "x;s =e" + using assms predecessor_point' by blast + have "s \ x\<^sup>T = s;(e\<^sup>T+-(e\<^sup>T)) \ x\<^sup>T" + using assms(2) point_equations(1) point_is_point by fastforce + also have "... = s;e\<^sup>T \ x\<^sup>T" + by (metis 1 conv_contrav inf.commute inf_sup_absorb modular_1') + also have "... \ e\<^sup>T" + by (metis assms(3) inf.coboundedI1 mult_isor point_equations(4) point_is_point + top_greatest) + finally have "s \ x\<^sup>T \ s \ e\<^sup>T" + by simp + also have "... \ s ; e\<^sup>T" + using assms(2,3) by (simp add: point_def vector_meet_comp) + finally have 2: "s \ x\<^sup>T \ -(s ; e\<^sup>T) = 0" + using galois_aux2 by blast + thus ?thesis + proof - + have "s ; e\<^sup>T = e\<^sup>T \ s" + using assms(2,3) inf_commute point_def vector_meet_comp by force + thus ?thesis + using 2 + by (metis assms(2,3) conv_compl conv_invol conv_one conv_times galois_aux + inf.assoc point_def point_equations(1) point_is_point schroeder_2 + vector_meet_comp) + qed + qed + with a show ?thesis + by simp + qed + show "start_points (x \ - (e ; s\<^sup>T)) \ s" + using assms(1,2,3,5) cycle_remove_edge(2) by blast + qed +next + show "e = end_points (x \ - (e ; s\<^sup>T))" + proof (simp only: eq_iff; rule conjI) + show "e \ end_points (x \ - (e ; s\<^sup>T))" + (* just copied and adapted the proof of the previous case (start_point) *) + proof - + have a: "e \ (x \ - (e ; s\<^sup>T))\<^sup>T;1" + proof - + have 1: "is_vector(-s)" + using assms(2) point_def vector_compl by blast + from assms(2-4) have "e = e \ -s" + using comp_assoc edge_end point_equations(1) point_equations(3) point_is_point by fastforce + also have "... \ x;s \ -s" + using assms(2,5) meet_iso point_def ss423bij by fastforce + also have "... \ x\<^sup>T;1 \ -s" + by (metis assms(1) many_strongly_connected_implies_no_start_end_points meet_iso mult_isol + top_greatest) + also have "... \ (x\<^sup>T \ -s);1" + using 1 by (simp add: vector_1_comm) + also have "... \ (x\<^sup>T \ - (s ; e\<^sup>T));1" + by (metis assms(2) comp_anti is_vector_def meet_isor mult_isol mult_isor point_def + top_greatest) + finally show ?thesis + by (simp add: conv_compl) + qed + have b: "e \ -((x \ - (e ; s\<^sup>T));1)" + proof - + have 1: "x\<^sup>T;e =s" + using assms predecessor_point' by (metis conv_contrav conv_invol conv_iso conv_path) + have "e \ x = e;(s\<^sup>T+-(s\<^sup>T)) \ x" + using assms(3) point_equations(1) point_is_point by fastforce + also have "... = e;s\<^sup>T \ x" + by (metis 1 conv_contrav conv_invol inf.commute inf_sup_absorb modular_1') + also have "... \ s\<^sup>T" + by (metis assms(2) inf.coboundedI1 mult_isor point_equations(4) point_is_point top_greatest) + finally have "e \ x \ e \ s\<^sup>T" + by simp + also have "... \ e ; s\<^sup>T" + using assms(2,3) by (simp add: point_def vector_meet_comp) + finally have 2: "e \ x \ -(e ; s\<^sup>T) = 0" + using galois_aux2 by blast + thus ?thesis + proof - + have "e ; s\<^sup>T = s\<^sup>T \ e" + using assms(2,3) inf_commute point_def vector_meet_comp by force + thus ?thesis + using 2 + by (metis assms(2,3) conv_one galois_aux inf.assoc point_def point_equations(1) + point_is_point schroeder_2 vector_meet_comp) + qed + qed + with a show ?thesis + by simp + qed + show "end_points (x \ - (e ; s\<^sup>T)) \ e" + using assms(1,2,3,5) cycle_remove_edge(3) by blast + qed +qed + +end (* context relation_algebra_rtc_tarski *) + +end diff --git a/thys/Relational_Paths/ROOT b/thys/Relational_Paths/ROOT new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/ROOT @@ -0,0 +1,19 @@ +chapter AFP + +session Relational_Paths (AFP) = Relation_Algebra + + + options [timeout = 600] + + sessions + Aggregation_Algebras + + theories + More_Relation_Algebra + Paths + Rooted_Paths + Path_Algorithms + + document_files + "root.tex" + "root.bib" + diff --git a/thys/Relational_Paths/Rooted_Paths.thy b/thys/Relational_Paths/Rooted_Paths.thy new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/Rooted_Paths.thy @@ -0,0 +1,1272 @@ +(* Title: Relational Characterisation of Rooted Paths + Author: Walter Guttmann, Peter Hoefner + Maintainer: Walter Guttmann + Peter Hoefner +*) + +section \Relational Characterisation of Rooted Paths\ + +text \ +We characterise paths together with a designated root. +This is important as often algorithms start with a single vertex, and then build up a path, a tree or another structure. +An example is Dijkstra's shortest path algorithm. +\ + +theory Rooted_Paths + +imports Paths + +begin + +context relation_algebra +begin + +text \General theorems\ + +lemma step_has_target: + assumes "x;r \ 0" + shows "x\<^sup>T;1 \ 0" +using assms inf.commute inf_bot_right schroeder_1 by fastforce + +lemma end_point_char: + "x\<^sup>T;p = 0 \ p \ -(x;1)" +using antisym bot_least compl_bot_eq conv_galois_1 by fastforce + +end (* relation_algebra *) + +context relation_algebra_tarski +begin + +text \General theorems concerning points\ + +lemma successor_point: + assumes "is_inj x" + and "point r" + and "x;r \ 0" + shows "point (x;r)" +using assms +by (simp add: inj_compose is_point_def is_vector_def mult_assoc point_is_point) + +lemma no_end_point_char: + assumes "point p" + shows "x\<^sup>T;p \ 0 \ p \ x;1" +by (simp add: assms comp_assoc end_point_char is_vector_def point_in_vector_or_complement_iff) + +lemma no_end_point_char_converse: + assumes "point p" + shows "x;p \ 0 \ p \ x\<^sup>T;1" +using assms no_end_point_char by force + +end (* relation_algebra_tarski *) + +subsection \Consequences without the Tarski rule\ + +context relation_algebra_rtc +begin + +text \Definitions for path classifications\ + +definition path_root + where "path_root r x \ r;x \ x\<^sup>\ + x\<^sup>T\<^sup>\ \ is_inj x \ is_p_fun x \ point r" + +abbreviation connected_root + where "connected_root r x \ r;x \ x\<^sup>+" + +definition backward_finite_path_root + where "backward_finite_path_root r x \ connected_root r x \ is_inj x \ is_p_fun x \ point r" + +abbreviation backward_terminating_path_root + where "backward_terminating_path_root r x \ backward_finite_path_root r x \ x;r = 0" + +abbreviation cycle_root + where "cycle_root r x \ r;x \ x\<^sup>+ \ x\<^sup>T;1 \ is_inj x \ is_p_fun x \ point r" + +abbreviation non_empty_cycle_root + where "non_empty_cycle_root r x \ backward_finite_path_root r x \ r \ x\<^sup>T;1" + +abbreviation finite_path_root_end + where "finite_path_root_end r x e \ backward_finite_path_root r x \ point e \ r \ x\<^sup>\;e" + +abbreviation terminating_path_root_end + where "terminating_path_root_end r x e \ finite_path_root_end r x e \ x\<^sup>T;e = 0" + +text \Equivalent formulations of \connected_root\\ + +lemma connected_root_iff1: + assumes "point r" + shows "connected_root r x \ 1;x \ r\<^sup>T;x\<^sup>+" +by (metis assms comp_assoc is_vector_def point_def ss423conv) + +lemma connected_root_iff2: + assumes "point r" + shows "connected_root r x \ x\<^sup>T;1 \ x\<^sup>T\<^sup>+;r" +by (metis assms conv_contrav conv_invol conv_iso conv_one star_conv star_slide_var + connected_root_iff1) + +lemma connected_root_aux: + "x\<^sup>T\<^sup>+;r \ x\<^sup>T;1" +by (simp add: comp_assoc mult_isol) + +lemma connected_root_iff3: + assumes "point r" + shows "connected_root r x \ x\<^sup>T;1 = x\<^sup>T\<^sup>+;r" +using assms antisym connected_root_aux connected_root_iff2 by fastforce + +lemma connected_root_iff4: + assumes "point r" + shows "connected_root r x \ 1;x = r\<^sup>T;x\<^sup>+" +by (metis assms conv_contrav conv_invol conv_one star_conv star_slide_var connected_root_iff3) + +text \Consequences of \connected_root\\ + +lemma has_root_contra: + assumes "connected_root r x" + and "point r" + and "x\<^sup>T;r = 0" + shows "x = 0" +using assms comp_assoc independence1 conv_zero ss_p18 connected_root_iff3 +by force + +lemma has_root: + assumes "connected_root r x" + and "point r" + and "x \ 0" + shows "x\<^sup>T;r \ 0" +using has_root_contra assms by blast + +lemma connected_root_move_root: + assumes "connected_root r x" + and "q \ x\<^sup>\;r" + shows "connected_root q x" +by (metis assms comp_assoc mult_isol phl_cons1 star_slide_var star_trans_eq) + +lemma root_cycle_converse: + assumes "connected_root r x" + and "point r" + and "x;r \ 0" + shows "x\<^sup>T;r \ 0" +using assms conv_zero has_root by fastforce + +text \Rooted paths\ + +lemma path_iff_aux_1: + assumes "bijective r" + shows "r;x \ x\<^sup>\ + x\<^sup>T\<^sup>\ \ x \ r\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\)" +by (simp add: assms ss423conv) + +lemma path_iff_aux_2: + assumes "bijective r" + shows "r;x \ x\<^sup>\ + x\<^sup>T\<^sup>\ \ x\<^sup>T \ (x\<^sup>\ + x\<^sup>T\<^sup>\);r" +proof - + have "((x\<^sup>\ + x\<^sup>T\<^sup>\);r)\<^sup>T = r\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\)" + by (metis conv_add conv_contrav conv_invol star_conv sup.commute) + thus ?thesis + by (metis assms conv_invol conv_iso path_iff_aux_1) +qed + +lemma path_iff_backward: + assumes "is_inj x" + and "is_p_fun x" + and "point r" + and "r;x \ x\<^sup>\ + x\<^sup>T\<^sup>\" + shows "connected x" +proof - + have "x\<^sup>T;1;x\<^sup>T \ (x\<^sup>\ + x\<^sup>T\<^sup>\);r;1;x\<^sup>T" + using assms(3,4) path_iff_aux_2 mult_isor point_def by blast + also have "... = (x\<^sup>\ + x\<^sup>T\<^sup>\);r;1;x\<^sup>T;x;x\<^sup>T" + using assms(1) comp_assoc inj_p_fun p_fun_triple by fastforce + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);r;x;x\<^sup>T" + by (metis assms(3) mult_double_iso top_greatest point_def is_vector_def comp_assoc) + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);(x\<^sup>\ + x\<^sup>T\<^sup>\);x\<^sup>T" + by (metis assms(4) comp_assoc mult_double_iso) + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);(x\<^sup>\ + x\<^sup>T\<^sup>\);(x\<^sup>\ + x\<^sup>T\<^sup>\)" + using le_supI2 mult_isol star_ext by blast + also have "... = x\<^sup>\ + x\<^sup>T\<^sup>\" + using assms(1,2) cancel_separate_converse_idempotent by fastforce + finally show ?thesis + by (metis conv_add conv_contrav conv_invol conv_one mult_assoc star_conv sup.orderE sup.orderI + sup_commute) +qed + +lemma empty_path_root_end: + assumes "terminating_path_root_end r x e" + shows "e = r \ x = 0" + apply(standard) + using assms has_root backward_finite_path_root_def apply blast +by (metis assms antisym conv_e conv_zero independence1 is_inj_def mult_oner point_swap + backward_finite_path_root_def ss423conv sur_def_var1 x_leq_triple_x) + +lemma path_root_acyclic: + assumes "path_root r x" + and "x;r = 0" + shows "is_acyclic x" +proof - + have "x\<^sup>+\1' = (x\<^sup>+)\<^sup>T\x\<^sup>+\1'" + by (metis conv_e conv_times inf.assoc inf.left_idem inf_le2 many_strongly_connected_iff_7 mult_oner star_subid) + also have "... \ x\<^sup>T;1\x\<^sup>+\1'" + by (metis conv_contrav inf.commute maddux_20 meet_double_iso plus_top star_conv star_slide_var) + finally have "r;(x\<^sup>+\1') \ r;(x\<^sup>T;1\x\<^sup>+\1')" + using mult_isol by blast + also have "... = (r\1;x);(x\<^sup>+\1')" + by (metis (no_types, lifting) comp_assoc conv_contrav conv_invol conv_one inf.assoc is_vector_def one_idem_mult vector_2) + also have "... = r;x;(x\<^sup>+\1')" + by (metis assms(1) path_root_def point_def inf_top_right vector_1) + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);(x\<^sup>+\1')" + using assms(1) mult_isor path_root_def by blast + also have "... = x\<^sup>\;(x\<^sup>+\1') + x\<^sup>T\<^sup>+;(x\<^sup>+\1')" + by (metis distrib_right star_star_plus sup.commute) + also have "... \ x\<^sup>\;(x\<^sup>+\1') + x\<^sup>T;1" + by (metis join_isol mult_isol plus_top top_greatest) + finally have "r;(x\<^sup>+\1');1 \ x\<^sup>\;(x\<^sup>+\1');1 + x\<^sup>T;1" + by (metis distrib_right inf_absorb2 mult_assoc mult_subdistr one_idem_mult) + hence 1: "r;(x\<^sup>+\1');1 \ x\<^sup>T;1" + by (metis assms(1) inj_implies_step_forwards_backwards sup_absorb2 path_root_def) + have "x\<^sup>+\1' \ (x\<^sup>+\1');1" + by (simp add: maddux_20) + also have "... \ r\<^sup>T;r;(x\<^sup>+\1');1" + by (metis assms(1) comp_assoc order.refl point_def ss423conv path_root_def) + also have "... \ r\<^sup>T;x\<^sup>T;1" + using 1 by (simp add: comp_assoc mult_isol) + also have "... = 0" + using assms(2) annil conv_contrav conv_zero by force + finally show ?thesis + using galois_aux le_bot by blast +qed + +text \Start points and end points\ + +lemma start_points_in_root_aux: + assumes "backward_finite_path_root r x" + shows "x;1 \ x\<^sup>T\<^sup>\;r" +proof - + have "x;1 \ x;x\<^sup>T\<^sup>+;r" + by (metis assms inf_top.left_neutral modular_var_2 mult_assoc connected_root_iff3 + backward_finite_path_root_def) + also have "... \ 1';x\<^sup>T\<^sup>\;r" + by (metis assms is_inj_def mult_assoc mult_isor backward_finite_path_root_def) + finally show ?thesis + by simp +qed + +lemma start_points_in_root: + assumes "backward_finite_path_root r x" + shows "start_points x \ r" +using assms galois_1 sup_commute connected_root_iff3 backward_finite_path_root_def + start_points_in_root_aux by fastforce + +lemma start_points_not_zero_contra: + assumes "connected_root r x" + and "point r" + and "start_points x = 0" + and "x;r = 0" + shows "x = 0" +proof - + have "x;1 \ x\<^sup>T;1" + using assms(3) galois_aux by force + also have "... \ -r" + using assms(4) comp_res compl_bot_eq by blast + finally show ?thesis + using assms(1,2) has_root_contra galois_aux schroeder_1 by force +qed + +lemma start_points_not_zero: + assumes "connected_root r x" + and "point r" + and "x \ 0" + and "x;r = 0" + shows "start_points x \ 0" +using assms start_points_not_zero_contra by blast + +text \Backwards terminating and backwards finite\ + +lemma backward_terminating_path_root_aux: + assumes "backward_terminating_path_root r x" + shows "x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" +proof - + have "x\<^sup>T\<^sup>\;r \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" + using assms comp_res compl_bot_eq compl_le_swap1 mult_isol by blast + thus ?thesis + using assms dual_order.trans maddux_20 start_points_in_root_aux by blast +qed + +lemma backward_finite_path_connected_aux: + assumes "backward_finite_path_root r x" + shows "x\<^sup>T;r;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" +proof - + have "x\<^sup>T;r;x\<^sup>T \ r\<^sup>T = x\<^sup>T;r;(x\<^sup>T \ r\<^sup>T)" + by (metis conv_invol conv_times vector_1_comm comp_assoc conv_contrav assms + backward_finite_path_root_def point_def) + also have "... \ x\<^sup>T;r;r\<^sup>T" + by (simp add: mult_isol) + also have 1: "... \ x\<^sup>T" + by (metis assms comp_assoc is_inj_def mult_1_right mult_isol point_def + backward_finite_path_root_def) + also have "... \ x\<^sup>T\<^sup>\" + by simp + finally have 2: "x\<^sup>T;r;x\<^sup>T \ r\<^sup>T \ x\<^sup>T\<^sup>\" . + let ?v = "x;1 \ -r" + have "?v \ x\<^sup>T\<^sup>+;r" + by (simp add: assms galois_1 start_points_in_root_aux) + hence "r\<^sup>T;x \ ?v \ r\<^sup>T;x \ x\<^sup>T\<^sup>+;r" + using meet_isor by blast + also have 3: "... = x\<^sup>T\<^sup>+;r \ 1;r\<^sup>T;x" + by (metis assms conv_contrav conv_one inf_commute is_vector_def point_def + backward_finite_path_root_def) + also have "... = (x\<^sup>T\<^sup>+;r \ 1);r\<^sup>T;x" + using 3 by (metis comp_assoc inf_commute is_vector_def star_conv vector_1 assms + backward_finite_path_root_def point_def) + also have "... = x\<^sup>T\<^sup>+;r;r\<^sup>T;x" + by simp + also have "... \ x\<^sup>T\<^sup>+;x" + using 1 by (metis mult_assoc mult_isol mult_isor star_slide_var) + also have "... = x\<^sup>T\<^sup>\;x\<^sup>T;x" + by (simp add: star_slide_var) + also have "... \ x\<^sup>T\<^sup>\" + by (metis assms backward_finite_path_root_def is_p_fun_def mult_1_right mult_assoc mult_isol_var + star_1l star_inductl_star) + finally have 4: "x\<^sup>T;r \ ?v\<^sup>T \ x\<^sup>\" + using conv_iso star_conv by force + have "x\<^sup>T;r;x\<^sup>T \ -r\<^sup>T = (x\<^sup>T;r \ 1);x\<^sup>T \ -r\<^sup>T" + by simp + also have "... = x\<^sup>T;r \ 1;x\<^sup>T \ -r\<^sup>T" + by (metis inf.commute is_vector_def comp_assoc vector_1 assms backward_finite_path_root_def + point_def) + also have "... \ x\<^sup>\" + using 4 by (simp add: conv_compl inf.assoc) + finally have "(x\<^sup>T;r;x\<^sup>T \ -r\<^sup>T) + (x\<^sup>T;r;x\<^sup>T \ r\<^sup>T) \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using 2 sup.mono by blast + thus ?thesis + by fastforce +qed + +lemma backward_finite_path_connected: + assumes "backward_finite_path_root r x" + shows "connected x" +proof - + from assms obtain r where 1: "backward_finite_path_root r x" .. + have "x\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\) = x\<^sup>T;(1' + x\<^sup>+) + x\<^sup>T\<^sup>+" + by (simp add: distrib_left) + also have "... = x\<^sup>T;x\<^sup>+ + x\<^sup>T\<^sup>+" + using calculation distrib_left star_star_plus by fastforce + also have "... \ 1';x\<^sup>\ + x\<^sup>T\<^sup>+" + using 1 by (metis add_iso comp_assoc is_p_fun_def mult_isor backward_finite_path_root_def) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using join_isol by fastforce + finally have "x\<^sup>T;r;x\<^sup>T + x\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\) \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using 1 backward_finite_path_connected_aux by simp + hence "x\<^sup>T\<^sup>\;x\<^sup>T;r;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using star_inductl comp_assoc by simp + hence "x\<^sup>T;1;x\<^sup>T \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using 1 backward_finite_path_root_def connected_root_iff3 star_slide_var by fastforce + thus ?thesis + by (metis (mono_tags, lifting) sup.commute comp_assoc conv_add conv_contrav conv_invol conv_iso + conv_one star_conv) +qed + +lemma backward_finite_path_root_path: + assumes "backward_finite_path_root r x" + shows "path x" +using assms path_def backward_finite_path_connected backward_finite_path_root_def by blast + +lemma backward_finite_path_root_path_root: + assumes "backward_finite_path_root r x" + shows "path_root r x" +using assms backward_finite_path_root_def le_supI1 star_star_plus path_root_def by fastforce + +lemma zero_backward_terminating_path_root: + assumes "point r" + shows "backward_terminating_path_root r 0" +by (simp add: assms is_inj_def is_p_fun_def backward_finite_path_root_def) + +lemma backward_finite_path_root_move_root: + assumes "backward_finite_path_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "backward_finite_path_root q x" +using assms connected_root_move_root backward_finite_path_root_def by blast + +text \Cycle\ + +lemma non_empty_cycle_root_var_axioms_1: + "non_empty_cycle_root r x \ x\<^sup>T;1 \ x\<^sup>T\<^sup>+;r \ is_inj x \ is_p_fun x \ point r \ r \ x\<^sup>T;1" +using connected_root_iff2 backward_finite_path_root_def by blast + +lemma non_empty_cycle_root_loop: + assumes "non_empty_cycle_root r x" + shows "r \ x\<^sup>T\<^sup>+;r" +using assms connected_root_iff3 backward_finite_path_root_def by fastforce + +lemma cycle_root_end_empty: + assumes "terminating_path_root_end r x e" + and "many_strongly_connected x" + shows "x = 0" +by (metis assms has_root_contra point_swap backward_finite_path_root_def + backward_finite_path_root_move_root star_conv) + +lemma cycle_root_end_empty_var: + assumes "terminating_path_root_end r x e" + and "x \ 0" + shows "\ many_strongly_connected x" +using assms cycle_root_end_empty by blast + +text \Terminating path\ + +lemma terminating_path_root_end_connected: + assumes "terminating_path_root_end r x e" + shows "x;1 \ x\<^sup>+;e" +proof - + have "x;1 \ x;x\<^sup>T;1" + by (metis comp_assoc inf_top.left_neutral modular_var_2) + also have "... = x;x\<^sup>T\<^sup>+;r" + using assms backward_finite_path_root_def connected_root_iff3 comp_assoc by fastforce + also have "... \ x;x\<^sup>T\<^sup>+;x\<^sup>\;e" + by (simp add: assms comp_assoc mult_isol) + also have "... = x;x\<^sup>T;(x\<^sup>\ + x\<^sup>T\<^sup>\);e" + using assms cancel_separate_p_fun_converse comp_assoc backward_finite_path_root_def by fastforce + also have "... = x;x\<^sup>T;(x\<^sup>+ + x\<^sup>T\<^sup>\);e" + by (simp add: star_star_plus) + also have "... = x;x\<^sup>T;x\<^sup>+;e + x;x\<^sup>T\<^sup>+;e" + by (simp add: comp_assoc distrib_left) + also have "... = x;x\<^sup>T;x\<^sup>+;e" + by (simp add: assms comp_assoc independence1) + also have "... \ x\<^sup>+;e" + by (metis assms annil independence1 is_inj_def mult_isor mult_oner backward_finite_path_root_def) + finally show ?thesis . +qed + +lemma terminating_path_root_end_forward_finite: + assumes "terminating_path_root_end r x e" + shows "backward_finite_path_root e (x\<^sup>T)" +using assms terminating_path_root_end_connected inj_p_fun connected_root_iff2 + backward_finite_path_root_def by force + +end (* relation_algebra_rtc *) + +subsection \Consequences with the Tarski rule\ + +context relation_algebra_rtc_tarski +begin + +text \Some (more) results about points\ + +lemma point_reachable_converse: + assumes "is_vector v" + and "v \ 0" + and "point r" + and "v \ x\<^sup>T\<^sup>+;r" + shows "r \ x\<^sup>+;v" +proof - + have "v\<^sup>T;v \ 0" + by (metis assms(2) inf.idem inf_bot_right mult_1_right schroeder_1) + hence "1;v\<^sup>T;v = 1" + using assms(1) is_vector_def mult_assoc tarski by force + hence 1: "r = r;v\<^sup>T;v" + by (metis assms(3) is_vector_def mult_assoc point_def) + have "v;r\<^sup>T \ x\<^sup>T\<^sup>+" + using assms(3,4) point_def ss423bij by simp + hence "r;v\<^sup>T \ x\<^sup>+" + by (metis conv_contrav conv_invol conv_iso star_conv star_slide_var) + thus ?thesis + using 1 by (metis mult_isor) +qed + +text \Roots\ + +lemma root_in_start_points: + assumes "connected_root r x" + and "is_vector r" + and "x \ 0" + and "x;r = 0" + shows "r \ start_points x" +proof - + have "r = r;x;1" + by (metis assms(2,3) comp_assoc is_vector_def tarski) + also have "... \ x;1" + by (metis assms(1) comp_assoc one_idem_mult phl_seq top_greatest) + finally show ?thesis + using assms(4) comp_res compl_bot_eq compl_le_swap1 inf.boundedI by blast +qed + +lemma root_equals_start_points: + assumes "backward_terminating_path_root r x" + and "x \ 0" + shows "r = start_points x" +using assms antisym point_def backward_finite_path_root_def start_points_in_root root_in_start_points +by fastforce + +lemma root_equals_end_points: + assumes "backward_terminating_path_root r (x\<^sup>T)" + and "x \ 0" + shows "r = end_points x" +by (metis assms conv_invol step_has_target ss_p18 root_equals_start_points) + +lemma root_in_edge_sources: + assumes "connected_root r x" + and "x \ 0" + and "is_vector r" + shows "r \ x;1" +proof - + have "r;1;x;1 \ x\<^sup>+;1" + using assms(1,3) is_vector_def mult_isor by fastforce + thus ?thesis + by (metis assms(2) comp_assoc conway.dagger_unfoldl_distr dual_order.trans maddux_20 sup.commute + sup_absorb2 tarski top_greatest) +qed + +text \Rooted Paths\ + +lemma non_empty_path_root_iff_aux: + assumes "path_root r x" + and "x \ 0" + shows "r \ (x + x\<^sup>T);1" +proof - + have "(r;x \ 1');1 = (x\<^sup>T;r\<^sup>T \ 1');1" + by (metis conv_contrav conv_e conv_times inf.cobounded2 is_test_def test_eq_conv) + also have "... \ x\<^sup>T;r\<^sup>T;1" + using mult_subdistr by blast + also have "... \ x\<^sup>T;1" + by (metis mult_assoc mult_double_iso one_idem_mult top_greatest) + finally have 1: "(r;x \ 1');1 \ x\<^sup>T;1" . + have "r \ r;1;x;1" + using assms(2) comp_assoc maddux_20 tarski by fastforce + also have "... = r;x;1" + using assms(1) path_root_def point_def is_vector_def by simp + also have "... = (r;x \ (x\<^sup>\ + x\<^sup>T\<^sup>\));1" + using assms(1) path_root_def by (simp add: inf.absorb_iff1) + also have "... = (r;x \ (x\<^sup>+ + x\<^sup>T\<^sup>+ + 1'));1" + by (metis star_star_plus star_unfoldl_eq sup_commute sup_left_commute) + also have "... \ (x\<^sup>+ + x\<^sup>T\<^sup>+ + (r;x \ 1'));1" + by (metis inf_le2 inf_sup_distrib1 mult_isor order_refl sup_mono) + also have "... \ x;1 + x\<^sup>T;1 + (r;x \ 1');1" + by (simp add: plus_top) + also have "... = x;1 + x\<^sup>T;1" + using 1 sup.coboundedI2 sup.order_iff by fastforce + finally show ?thesis + by simp +qed + +text \Backwards terminating and backwards finite\ + +lemma backward_terminating_path_root_2: + assumes "backward_terminating_path_root r x" + shows "backward_terminating x" +using assms backward_terminating_iff2 path_def backward_terminating_path_root_aux + backward_finite_path_connected backward_finite_path_root_def by blast + +lemma backward_terminating_path_root: + assumes "backward_terminating_path_root r x" + shows "backward_terminating_path x" +using assms backward_finite_path_root_path backward_terminating_path_root_2 by fastforce + +text \(Non-empty) Cycle\ + +lemma cycle_iff: + assumes "point r" + shows "x;r \ 0 \ r \ x\<^sup>T;1" +by (simp add: assms no_end_point_char_converse) + +lemma non_empty_cycle_root_iff: + assumes "connected_root r x" + and "point r" + shows "x;r \ 0 \ r \ x\<^sup>T\<^sup>+;r" +using assms connected_root_iff3 cycle_iff by simp + +lemma backward_finite_path_root_terminating_or_cycle: + "backward_finite_path_root r x \ backward_terminating_path_root r x \ non_empty_cycle_root r x" +using cycle_iff backward_finite_path_root_def by blast + +lemma non_empty_cycle_root_msc: + assumes "non_empty_cycle_root r x" + shows "many_strongly_connected x" +proof - + let ?p = "x\<^sup>T;r" + have 1: "is_point ?p" + unfolding is_point_def + using conjI assms is_vector_def mult_assoc point_def inj_compose p_fun_inj + cycle_iff backward_finite_path_root_def root_cycle_converse by fastforce + have "?p \ x\<^sup>T\<^sup>+;?p" + by (metis assms comp_assoc mult_isol star_slide_var non_empty_cycle_root_loop) + hence "?p \ x\<^sup>+;?p" + using 1 bot_least point_def point_is_point point_reachable_converse by blast + also have "... = x\<^sup>\;(x;x\<^sup>T);r" + by (metis comp_assoc star_slide_var) + also have "... \ x\<^sup>\;1';r" + using assms is_inj_def mult_double_iso backward_finite_path_root_def by blast + finally have 2: "?p \ x\<^sup>\;r" + by simp + have "x\<^sup>T;x\<^sup>\;r = ?p + x\<^sup>T;x\<^sup>+;r" + by (metis conway.dagger_unfoldl_distr distrib_left mult_assoc) + also have "... \ ?p + 1';x\<^sup>\;r" + by (metis assms is_p_fun_def join_isol mult_assoc mult_isor backward_finite_path_root_def) + also have "... = x\<^sup>\;r" + using 2 by (simp add: sup_absorb2) + finally have 3: "x\<^sup>T\<^sup>\;r \ x\<^sup>\;r" + by (metis star_inductl comp_assoc conway.dagger_unfoldl_distr le_supI order_prop) + have "x\<^sup>T \ x\<^sup>T\<^sup>+;r" + by (metis assms maddux_20 connected_root_iff3 backward_finite_path_root_def) + also have "... \ x\<^sup>\;r" + using 3 by (metis assms conway.dagger_unfoldl_distr sup_absorb2 non_empty_cycle_root_loop) + finally have 4: "x\<^sup>T \ x\<^sup>\;r" . + have "x\<^sup>T \ x\<^sup>T;x;x\<^sup>T" + by (metis conv_invol x_leq_triple_x) + also have "... \ 1;x;x\<^sup>T" + by (simp add: mult_isor) + also have "... = r\<^sup>T;x\<^sup>+;x\<^sup>T" + using assms connected_root_iff4 backward_finite_path_root_def by fastforce + also have "... \ r\<^sup>T;x\<^sup>\" + by (metis assms is_inj_def mult_1_right mult_assoc mult_isol backward_finite_path_root_def + star_slide_var) + finally have "x\<^sup>T \ x\<^sup>\;r \ r\<^sup>T;x\<^sup>\" + using 4 by simp + also have "... = x\<^sup>\;r \ 1;r\<^sup>T;x\<^sup>\" + by (metis assms conv_contrav conv_one is_vector_def point_def backward_finite_path_root_def) + also have "... = (x\<^sup>\;r \ 1);r\<^sup>T;x\<^sup>\" + by (metis (no_types, lifting) assms is_vector_def mult_assoc point_def + backward_finite_path_root_def vector_1) + also have "... = x\<^sup>\;r;r\<^sup>T;x\<^sup>\" + by simp + also have "... \ x\<^sup>\;x\<^sup>\" + by (metis assms is_inj_def mult_1_right mult_assoc mult_isol mult_isor point_def + backward_finite_path_root_def) + also have "... \ x\<^sup>\" + by simp + finally show ?thesis + by (simp add: many_strongly_connected_iff_1) +qed + +lemma non_empty_cycle_root_msc_cycle: + assumes "non_empty_cycle_root r x" + shows "cycle x" +using assms backward_finite_path_root_path non_empty_cycle_root_msc by fastforce + +lemma non_empty_cycle_root_non_empty: + assumes "non_empty_cycle_root r x" + shows "x \ 0" +using assms cycle_iff annil backward_finite_path_root_def by blast + +lemma non_empty_cycle_root_rtc_symmetric: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>\;r = x\<^sup>T\<^sup>\;r" +using assms non_empty_cycle_root_msc by fastforce + +lemma non_empty_cycle_root_point_exchange: + assumes "non_empty_cycle_root r x" + and "point p" + shows "r \ x\<^sup>\;p \ p \ x\<^sup>\;r" +by (metis assms(1,2) inj_sur_semi_swap point_def non_empty_cycle_root_msc + backward_finite_path_root_def star_conv) + +lemma non_empty_cycle_root_rtc_tc: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>\;r = x\<^sup>+;r" +proof (rule antisym) + have "r \ x\<^sup>+;r" + using assms many_strongly_connected_iff_7 non_empty_cycle_root_loop non_empty_cycle_root_msc + by simp + thus "x\<^sup>\;r \ x\<^sup>+;r" + using sup_absorb2 by fastforce +next + show "x\<^sup>+;r \ x\<^sup>\;r" + by (simp add: mult_isor) +qed + +lemma non_empty_cycle_root_no_start_end_points: + assumes "non_empty_cycle_root r x" + shows "x;1 = x\<^sup>T;1" +using assms many_strongly_connected_implies_no_start_end_points non_empty_cycle_root_msc by blast + +lemma non_empty_cycle_root_move_root: + assumes "non_empty_cycle_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "non_empty_cycle_root q x" +by (metis assms cycle_iff dual_order.trans backward_finite_path_root_move_root start_points_in_root + root_equals_start_points non_empty_cycle_root_non_empty) + +lemma non_empty_cycle_root_loop_converse: + assumes "non_empty_cycle_root r x" + shows "r \ x\<^sup>+;r" +using assms less_eq_def non_empty_cycle_root_rtc_tc by fastforce + +lemma non_empty_cycle_root_move_root_same_reachable: + assumes "non_empty_cycle_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "x\<^sup>\;r = x\<^sup>\;q" +by (metis assms many_strongly_connected_iff_7 connected_root_iff3 connected_root_move_root + backward_finite_path_root_def non_empty_cycle_root_msc non_empty_cycle_root_rtc_tc) + +lemma non_empty_cycle_root_move_root_same_reachable_2: + assumes "non_empty_cycle_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "x\<^sup>\;r = x\<^sup>T\<^sup>\;q" +using assms non_empty_cycle_root_move_root_same_reachable non_empty_cycle_root_msc by simp + +lemma non_empty_cycle_root_move_root_msc: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>T\<^sup>\;q = x\<^sup>\;q" +using assms non_empty_cycle_root_msc by simp + +lemma non_empty_cycle_root_move_root_rtc_tc: + assumes "non_empty_cycle_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "x\<^sup>\;q = x\<^sup>+;q" +using assms non_empty_cycle_root_move_root non_empty_cycle_root_rtc_tc by blast + +lemma non_empty_cycle_root_move_root_loop_converse: + assumes "non_empty_cycle_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "q \ x\<^sup>T\<^sup>+;q" +using assms non_empty_cycle_root_loop non_empty_cycle_root_move_root by blast + +lemma non_empty_cycle_root_move_root_loop: + assumes "non_empty_cycle_root r x" + and "point q" + and "q \ x\<^sup>\;r" + shows "q \ x\<^sup>+;q" +using assms non_empty_cycle_root_loop_converse non_empty_cycle_root_move_root by blast + +lemma non_empty_cycle_root_msc_plus: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>+;r = x\<^sup>T\<^sup>+;r" +using assms many_strongly_connected_iff_7 non_empty_cycle_root_msc by fastforce + +lemma non_empty_cycle_root_tc_start_points: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>+;r = x;1" +by (metis assms connected_root_iff3 backward_finite_path_root_def non_empty_cycle_root_msc_plus + non_empty_cycle_root_no_start_end_points) + +lemma non_empty_cycle_root_rtc_start_points: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>\;r = x;1" +by (simp add: assms non_empty_cycle_root_rtc_tc non_empty_cycle_root_tc_start_points) + +lemma non_empty_cycle_root_converse_start_end_points: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>T \ x;1;x" +by (metis assms conv_contrav conv_invol conv_one inf.boundedI maddux_20 maddux_21 vector_meet_comp_x + non_empty_cycle_root_no_start_end_points) + +lemma non_empty_cycle_root_start_end_points_plus: + assumes "non_empty_cycle_root r x" + shows "x;1;x \ x\<^sup>+" +using assms eq_iff one_strongly_connected_iff one_strongly_connected_implies_7_eq + backward_finite_path_connected non_empty_cycle_root_msc by blast + +lemma non_empty_cycle_root_converse_plus: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>T \ x\<^sup>+" +using assms many_strongly_connected_iff_2 non_empty_cycle_root_msc by blast + +lemma non_empty_cycle_root_plus_converse: + assumes "non_empty_cycle_root r x" + shows "x\<^sup>+ = x\<^sup>T\<^sup>+" +using assms many_strongly_connected_iff_7 non_empty_cycle_root_msc by fastforce + +lemma non_empty_cycle_root_converse: + assumes "non_empty_cycle_root r x" + shows "non_empty_cycle_root r (x\<^sup>T)" +by (metis assms conv_invol inj_p_fun connected_root_iff3 backward_finite_path_root_def + non_empty_cycle_root_msc_plus non_empty_cycle_root_tc_start_points) + +lemma non_empty_cycle_root_move_root_forward: + assumes "non_empty_cycle_root r x" + and "point q" + and "r \ x\<^sup>\;q" + shows "non_empty_cycle_root q x" +by (metis assms backward_finite_path_root_move_root non_empty_cycle_root_no_start_end_points + non_empty_cycle_root_point_exchange non_empty_cycle_root_rtc_start_points) + +lemma non_empty_cycle_root_move_root_forward_cycle: + assumes "non_empty_cycle_root r x" + and "point q" + and "r \ x\<^sup>\;q" + shows "x;q \ 0 \ x\<^sup>T;q \ 0" +by (metis assms comp_assoc independence1 ss_p18 non_empty_cycle_root_move_root_forward + non_empty_cycle_root_msc_plus non_empty_cycle_root_non_empty + non_empty_cycle_root_tc_start_points) + +lemma non_empty_cycle_root_equivalences: + assumes "non_empty_cycle_root r x" + and "point q" + shows "(r \ x\<^sup>\;q \ q \ x\<^sup>\;r)" + and "(r \ x\<^sup>\;q \ x;q \ 0)" + and "(r \ x\<^sup>\;q \ x\<^sup>T;q \ 0)" + and "(r \ x\<^sup>\;q \ q \ x;1)" + and "(r \ x\<^sup>\;q \ q \ x\<^sup>T;1)" +using assms cycle_iff no_end_point_char non_empty_cycle_root_no_start_end_points + non_empty_cycle_root_point_exchange non_empty_cycle_root_rtc_start_points +by metis+ + +lemma non_empty_cycle_root_chord: + assumes "non_empty_cycle_root r x" + and "point p" + and "point q" + and "r \ x\<^sup>\;p" + and "r \ x\<^sup>\;q" + shows "p \ x\<^sup>\;q" +using assms non_empty_cycle_root_move_root_same_reachable non_empty_cycle_root_point_exchange +by fastforce + +lemma non_empty_cycle_root_var_axioms_2: + "non_empty_cycle_root r x \ x;1 \ x\<^sup>+;r \ is_inj x \ is_p_fun x \ point r \ r \ x;1" +apply (rule iffI) + apply (metis eq_iff backward_finite_path_root_def non_empty_cycle_root_no_start_end_points + non_empty_cycle_root_tc_start_points) +by (metis conv_invol p_fun_inj connected_root_iff2 connected_root_iff3 + non_empty_cycle_root_var_axioms_1 non_empty_cycle_root_msc_plus + non_empty_cycle_root_rtc_start_points non_empty_cycle_root_rtc_tc) + +lemma non_empty_cycle_root_var_axioms_3: + "non_empty_cycle_root r x \ x;1 \ x\<^sup>+;r \ is_inj x \ is_p_fun x \ point r \ r \ x\<^sup>+;x;1" +apply (rule iffI) + apply (metis comp_assoc eq_refl backward_finite_path_root_def star_inductl_var_eq2 + non_empty_cycle_root_no_start_end_points non_empty_cycle_root_rtc_start_points + non_empty_cycle_root_tc_start_points) +by (metis annir comp_assoc conv_contrav no_end_point_char non_empty_cycle_root_var_axioms_2) + +lemma non_empty_cycle_root_subset_equals: + assumes "non_empty_cycle_root r x" + and "non_empty_cycle_root r y" + and "x \ y" + shows "x = y" +proof - + have "y;x\<^sup>T\<^sup>\;r = y;x\<^sup>T\<^sup>+;r" + using assms(1) comp_assoc non_empty_cycle_root_msc non_empty_cycle_root_msc_plus + non_empty_cycle_root_rtc_tc by fastforce + also have "... \ y;y\<^sup>T;x\<^sup>T\<^sup>\;r" + using assms(3) comp_assoc conv_iso mult_double_iso by fastforce + also have "... \ x\<^sup>T\<^sup>\;r" + using assms(2) backward_finite_path_root_def is_inj_def + by (meson dual_order.trans mult_isor order.refl prod_star_closure star_ref) + finally have "r + y;x\<^sup>T\<^sup>\;r \ x\<^sup>T\<^sup>\;r" + by (metis conway.dagger_unfoldl_distr le_supI sup.cobounded1) + hence "y\<^sup>\;r \ x\<^sup>T\<^sup>\;r" + by (simp add: comp_assoc rtc_inductl) + hence "y;1 \ x;1" + using assms(1,2) non_empty_cycle_root_msc non_empty_cycle_root_rtc_start_points by fastforce + thus ?thesis + using assms(2,3) backward_finite_path_root_def ss422iv by blast +qed + +lemma non_empty_cycle_root_subset_equals_change_root: + assumes "non_empty_cycle_root r x" + and "non_empty_cycle_root q y" + and "x \ y" + shows "x = y" +proof - + have "r \ y;1" + by (metis assms(1,3) dual_order.trans mult_isor non_empty_cycle_root_no_start_end_points) + hence "non_empty_cycle_root r y" + by (metis assms(1,2) connected_root_move_root backward_finite_path_root_def + non_empty_cycle_root_no_start_end_points non_empty_cycle_root_rtc_start_points) + thus ?thesis + using assms(1,3) non_empty_cycle_root_subset_equals by blast +qed + +lemma non_empty_cycle_root_equivalences_2: + assumes "non_empty_cycle_root r x" + shows "(v \ x\<^sup>\;r \ v \ x\<^sup>T;1)" + and "(v \ x\<^sup>\;r \ v \ x;1)" +using assms non_empty_cycle_root_no_start_end_points non_empty_cycle_root_rtc_start_points +by metis+ + +lemma cycle_root_non_empty: + assumes "x \ 0" + shows "cycle_root r x \ non_empty_cycle_root r x" +proof + assume 1: "cycle_root r x" + have "r \ r;1;x;1" + using assms comp_assoc maddux_20 tarski by fastforce + also have "... \ (x\<^sup>+ \ x\<^sup>T;1);1" + using 1 by (simp add: is_vector_def mult_isor point_def) + also have "... \ x\<^sup>T;1" + by (simp add: ra_1) + finally show "non_empty_cycle_root r x" + using 1 backward_finite_path_root_def inf.boundedE by blast +next + assume "non_empty_cycle_root r x" + thus "cycle_root r x" + by (metis backward_finite_path_root_def inf.orderE maddux_20 non_empty_cycle_root_plus_converse + ra_1) +qed + +text \Start points and end points\ + +lemma start_points_path_aux: + assumes "backward_finite_path_root r x" + and "start_points x \ 0" + shows "x;r = 0" +by (metis assms compl_inf_bot inf.commute non_empty_cycle_root_no_start_end_points + backward_finite_path_root_terminating_or_cycle) + +lemma start_points_path: + assumes "backward_finite_path_root r x" + and "start_points x \ 0" + shows "backward_terminating_path_root r x" +by (simp add: assms start_points_path_aux) + +lemma root_in_start_points_2: + assumes "backward_finite_path_root r x" + and "start_points x \ 0" + shows "r \ start_points x" +by (metis assms conv_zero eq_refl galois_aux2 root_equals_start_points start_points_path_aux) + +lemma root_equals_start_points_2: + assumes "backward_finite_path_root r x" + and "start_points x \ 0" + shows "r = start_points x" +by (metis assms inf_bot_left ss_p18 root_equals_start_points start_points_path) + +lemma start_points_injective: + assumes "backward_finite_path_root r x" + shows "is_inj (start_points x)" +by (metis assms compl_bot_eq inj_def_var1 point_def backward_finite_path_root_def top_greatest + root_equals_start_points_2) + +lemma backward_terminating_path_root_aux_2: + assumes "backward_finite_path_root r x" + and "start_points x \ 0 \ x = 0" + shows "x \ x\<^sup>T\<^sup>\;-(x\<^sup>T;1)" +using assms bot_least backward_terminating_path_root_aux start_points_path by blast + +lemma start_points_not_zero_iff: + assumes "backward_finite_path_root r x" + shows "x;r = 0 \ x \ 0 \ start_points x \ 0" +by (metis assms conv_zero inf_compl_bot backward_finite_path_root_def start_points_not_zero_contra + start_points_path_aux) + +text \Backwards terminating and backwards finite: Part II\ + +lemma backward_finite_path_root_acyclic_terminating_aux: + assumes "backward_finite_path_root r x" + and "is_acyclic x" + shows "x;r = 0" +proof (cases "x = 0") + assume "x = 0" + thus ?thesis + by simp +next + assume "x \ 0" + hence 1: "r \ x;1" + using assms(1) has_root_contra no_end_point_char backward_finite_path_root_def by blast + have "r\(x\<^sup>T;1) = r\(x\<^sup>T\<^sup>+;r)" + using assms(1) connected_root_iff3 backward_finite_path_root_def by fastforce + also have "... \ r\(-1';r)" + by (metis assms(2) conv_compl conv_contrav conv_e conv_iso meet_isor mult_isor star_conv + star_slide_var) + also have "... = 0" + by (metis (no_types) assms(1) inj_distr annil inf_compl_bot mult_1_left point_def + backward_finite_path_root_def) + finally have "r \ start_points x" + using 1 galois_aux inf.boundedI le_bot by blast + thus ?thesis + using assms(1) annir le_bot start_points_path by blast +qed + +lemma backward_finite_path_root_acyclic_terminating_iff: + assumes "backward_finite_path_root r x" + shows "is_acyclic x \ x;r = 0" + apply (rule iffI) +apply (simp add: assms backward_finite_path_root_acyclic_terminating_aux) +using assms backward_finite_path_root_path_root path_root_acyclic by blast + +lemma backward_finite_path_root_acyclic_terminating: + assumes "backward_finite_path_root r x" + and "is_acyclic x" + shows "backward_terminating_path_root r x" +by (simp add: assms backward_finite_path_root_acyclic_terminating_aux) + +lemma non_empty_cycle_root_one_strongly_connected: + assumes "non_empty_cycle_root r x" + shows "one_strongly_connected x" +by (metis assms one_strongly_connected_iff order_trans star_1l star_star_plus sup.absorb2 + non_empty_cycle_root_msc non_empty_cycle_root_start_end_points_plus) + +lemma backward_finite_path_root_nodes_reachable: + assumes "backward_finite_path_root r x" + and "v \ x;1 + x\<^sup>T;1" + and "is_sur v" + shows "r \ x\<^sup>\;v" +proof - + have "v \ x;1 + x\<^sup>T\<^sup>+;r" + using assms connected_root_iff3 backward_finite_path_root_def by fastforce + also have "... \ x\<^sup>T\<^sup>\;r + x\<^sup>T\<^sup>+;r" + using assms(1) join_iso start_points_in_root_aux by blast + also have "... = x\<^sup>T\<^sup>\;r" + using mult_isor sup.absorb1 by fastforce + finally show ?thesis + using assms(1,3) + by (simp add: inj_sur_semi_swap point_def backward_finite_path_root_def star_conv + inj_sur_semi_swap_short) +qed + +lemma terminating_path_root_end_backward_terminating: + assumes "terminating_path_root_end r x e" + shows "backward_terminating_path_root r x" +using assms non_empty_cycle_root_move_root_forward_cycle + backward_finite_path_root_terminating_or_cycle by blast + +lemma terminating_path_root_end_converse: + assumes "terminating_path_root_end r x e" + shows "terminating_path_root_end e (x\<^sup>T) r" +by (metis assms terminating_path_root_end_backward_terminating backward_finite_path_root_def + conv_invol terminating_path_root_end_forward_finite point_swap star_conv) + +lemma terminating_path_root_end_forward_terminating: + assumes "terminating_path_root_end r x e" + shows "backward_terminating_path_root e (x\<^sup>T)" +using assms terminating_path_root_end_converse by blast + +end (* relation_algebra_rtc_tarski *) + +subsection \Consequences with the Tarski rule and the point axiom\ + +context relation_algebra_rtc_tarski_point +begin + +text \Rooted paths\ + +lemma path_root_iff: + "(\r . path_root r x) \ path x" +proof + assume "\r . path_root r x" + thus "path x" + using path_def path_iff_backward point_def path_root_def by blast +next + assume 1: "path x" + show "\r . path_root r x" + proof (cases "x = 0") + assume "x = 0" + thus ?thesis + by (simp add: is_inj_def is_p_fun_def point_exists path_root_def) + next + assume "\(x = 0)" + hence "x;1 \ 0" + by (simp add: ss_p18) + from this obtain r where 2: "point r \ r \ x;1" + using comp_assoc is_vector_def one_idem_mult point_below_vector by fastforce + hence "r;x \ x;1;x" + by (simp add: mult_isor) + also have "... \ x\<^sup>\ + x\<^sup>T\<^sup>\" + using 1 path_def by blast + finally show ?thesis + using 1 2 path_def path_root_def by blast + qed +qed + +lemma non_empty_path_root_iff: + "(\r . path_root r x \ r \ (x + x\<^sup>T);1) \ path x \ x \ 0" +apply (rule iffI) + using non_empty_cycle_root_non_empty path_root_def zero_backward_terminating_path_root path_root_iff + apply fastforce +using path_root_iff non_empty_path_root_iff_aux by blast + +text \(Non-empty) Cycle\ + +lemma non_empty_cycle_root_iff: + "(\r . non_empty_cycle_root r x) \ cycle x \ x \ 0" +proof + assume "\r . non_empty_cycle_root r x" + thus "cycle x \ x \ 0" + using non_empty_cycle_root_msc_cycle non_empty_cycle_root_non_empty by fastforce +next + assume 1: "cycle x \ x \ 0" + hence "x\<^sup>T;1 \ 0" + using many_strongly_connected_implies_no_start_end_points ss_p18 by blast + from this obtain r where 2: "point r \ r \ x\<^sup>T;1" + using comp_assoc is_vector_def one_idem_mult point_below_vector by fastforce + have 3: "x\<^sup>T;1;x\<^sup>T \ x\<^sup>\" + using 1 one_strongly_connected_iff path_def by blast + have "r;x \ x\<^sup>T;1;x" + using 2 by (simp add: is_vector_def mult_isor point_def) + also have "... \ x\<^sup>T;1;x;x\<^sup>T;x" + using comp_assoc mult_isol x_leq_triple_x by fastforce + also have "... \ x\<^sup>T;1;x\<^sup>T;x" + by (metis mult_assoc mult_double_iso top_greatest) + also have "... \ x\<^sup>\;x" + using 3 mult_isor by blast + finally have "connected_root r x" + by (simp add: star_slide_var) + hence "non_empty_cycle_root r x" + using 1 2 path_def backward_finite_path_root_def by fastforce + thus "\r . non_empty_cycle_root r x" .. +qed + +lemma non_empty_cycle_subset_equals: + assumes "cycle x" + and "cycle y" + and "x \ y" + and "x \ 0" + shows "x = y" +by (metis assms le_bot non_empty_cycle_root_subset_equals_change_root non_empty_cycle_root_iff) + +lemma cycle_root_iff: + "(\r . cycle_root r x) \ cycle x" +proof (cases "x = 0") + assume "x = 0" + thus ?thesis + using path_def point_exists by fastforce +next + assume "x \ 0" + thus ?thesis + using cycle_root_non_empty non_empty_cycle_root_iff by simp +qed + +text \Backwards terminating and backwards finite\ + +lemma backward_terminating_path_root_iff: + "(\r . backward_terminating_path_root r x) \ backward_terminating_path x" +proof + assume "\r . backward_terminating_path_root r x" + thus "backward_terminating_path x" + using backward_terminating_path_root by fastforce +next + assume 1: "backward_terminating_path x" + show "\r . backward_terminating_path_root r x" + proof (cases "x = 0") + assume "x = 0" + thus ?thesis + using point_exists zero_backward_terminating_path_root by blast + next + let ?r = "start_points x" + assume "x \ 0" + hence 2: "is_point ?r" + using 1 start_point_iff2 backward_terminating_iff1 by fastforce + have 3: "x;?r = 0" + by (metis inf_top.right_neutral modular_1_aux') + have "x;1;x \ x;1;x;x\<^sup>T;x" + using comp_assoc mult_isol x_leq_triple_x by fastforce + also have "... \ (x\<^sup>\ + x\<^sup>T\<^sup>\);x\<^sup>T;x" + using 1 mult_isor path_def by blast + also have "... = (1' + x\<^sup>+ + x\<^sup>T\<^sup>+);x\<^sup>T;x" + by (metis star_star_plus star_unfoldl_eq sup.commute) + also have "... = x\<^sup>T;x + x\<^sup>+;x\<^sup>T;x + x\<^sup>T\<^sup>+;x\<^sup>T;x" + by (metis distrib_right' mult_onel) + also have "... = x\<^sup>T;(x + x\<^sup>T\<^sup>\;x\<^sup>T;x) + x\<^sup>+;x\<^sup>T;x" + using comp_assoc distrib_left sup.commute sup.assoc by simp + also have "... \ x\<^sup>T;1 + x\<^sup>+;x\<^sup>T;x" + using join_iso mult_isol by fastforce + also have "... \ x\<^sup>T;1 + x\<^sup>+;1'" + using 1 by (metis comp_assoc join_isol mult_isol path_def is_p_fun_def) + finally have "-(x\<^sup>T;1) \ x;1;x \ x\<^sup>+" + by (simp add: galois_1 inf.commute) + hence "?r;x \ x\<^sup>+" + by (metis inf_commute one_compl ra_1) + hence "backward_terminating_path_root ?r x" + using 1 2 3 by (simp add: point_is_point backward_finite_path_root_def path_def) + thus ?thesis .. + qed +qed + +lemma non_empty_backward_terminating_path_root_iff: + "backward_terminating_path_root (start_points x) x \ backward_terminating_path x \ x \ 0" +apply (rule iffI) + apply (metis backward_finite_path_root_path backward_terminating_path_root_2 conv_zero + inf.cobounded1 non_empty_cycle_root_non_empty) +using backward_terminating_path_root_iff root_equals_start_points by blast + +lemma non_empty_backward_terminating_path_root_iff': + "backward_finite_path_root (start_points x) x \ backward_terminating_path x \ x \ 0" +using start_point_no_predecessor non_empty_backward_terminating_path_root_iff by simp + +lemma backward_finite_path_root_iff: + "(\r . backward_finite_path_root r x) \ backward_finite_path x" +proof + assume "\r . backward_finite_path_root r x" + thus "backward_finite_path x" + by (meson backward_finite_iff_msc non_empty_cycle_root_msc backward_finite_path_root_path + backward_finite_path_root_terminating_or_cycle backward_terminating_path_root) +next + assume "backward_finite_path x" + thus "\r . backward_finite_path_root r x" + by (metis backward_finite_iff_msc point_exists non_empty_cycle_root_iff + zero_backward_terminating_path_root backward_terminating_path_root_iff) +qed + +lemma non_empty_backward_finite_path_root_iff: + "(\r . backward_finite_path_root r x \ r \ x;1) \ backward_finite_path x \ x \ 0" +apply (rule iffI) + apply (metis backward_finite_path_root_iff annir backward_finite_path_root_def le_bot + no_end_point_char ss_p18) +using backward_finite_path_root_iff backward_finite_path_root_def point_def root_in_edge_sources by blast + +text \Terminating\ + +lemma terminating_path_root_end_aux: + assumes "terminating_path x" + shows "\r e . terminating_path_root_end r x e" +proof (cases "x = 0") + assume "x = 0" + thus ?thesis + using point_exists zero_backward_terminating_path_root by fastforce +next + assume 1: "\(x = 0)" + have 2: "backward_terminating_path x" + using assms by simp + from this obtain r where 3: "backward_terminating_path_root r x" + using backward_terminating_path_root_iff by blast + have "backward_terminating_path (x\<^sup>T)" + using 2 by (metis assms backward_terminating_iff1 conv_backward_terminating_path conv_invol + conv_zero inf_top.left_neutral) + from this obtain e where 4: "backward_terminating_path_root e (x\<^sup>T)" + using backward_terminating_path_root_iff by blast + have "r \ x;1" + using 1 3 root_in_edge_sources backward_finite_path_root_def point_def by fastforce + also have "... = x\<^sup>+;e" + using 4 connected_root_iff3 backward_finite_path_root_def by fastforce + also have "... \ x\<^sup>\;e" + by (simp add: mult_isor) + finally show ?thesis + using 3 4 backward_finite_path_root_def by blast +qed + +lemma terminating_path_root_end_iff: + "(\r e . terminating_path_root_end r x e) \ terminating_path x" +proof + assume 1: "\r e . terminating_path_root_end r x e" + show "terminating_path x" + proof (cases "x = 0") + assume "x = 0" + thus ?thesis + by (simp add: is_inj_def is_p_fun_def path_def) + next + assume "\(x = 0)" + hence 2: "\ many_strongly_connected x" + using 1 cycle_root_end_empty by blast + hence 3: "backward_terminating_path x" + using 1 backward_terminating_path_root terminating_path_root_end_backward_terminating by blast + have "\e . backward_finite_path_root e (x\<^sup>T)" + using 1 terminating_path_root_end_converse by blast + hence "backward_terminating_path (x\<^sup>T)" + using 1 backward_terminating_path_root terminating_path_root_end_converse by blast + hence "forward_terminating_path x" + by (simp add: conv_backward_terminating_path) + thus ?thesis + using 3 by (simp add: inf.boundedI) + qed +next + assume "terminating_path x" + thus "\r e . terminating_path_root_end r x e" + using terminating_path_root_end_aux by blast +qed + +lemma non_empty_terminating_path_root_end_iff: + "terminating_path_root_end (start_points x) x (end_points x) \ terminating_path x \ x \ 0" +apply (rule iffI) + apply (metis conv_zero non_empty_backward_terminating_path_root_iff terminating_path_root_end_iff) +using terminating_path_root_end_iff terminating_path_root_end_forward_terminating + root_equals_end_points terminating_path_root_end_backward_terminating root_equals_start_points +by blast + +lemma non_empty_finite_path_root_end_iff: + "finite_path_root_end (start_points x) x (end_points x) \ terminating_path x \ x \ 0" +using non_empty_terminating_path_root_end_iff end_point_no_successor by simp + +end (* relation_algebra_rtc_tarski_point *) + +end diff --git a/thys/Relational_Paths/document/root.bib b/thys/Relational_Paths/document/root.bib new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/document/root.bib @@ -0,0 +1,112 @@ +@STRING{afp = {Archive of Formal Proofs}} +@STRING{jlamp = {Journal of Logical and Algebraic Methods in Programming}} +@STRING{jsl = {The Journal of Symbolic Logic}} +@STRING{sv = {Springer}} + +@Article{ArmstrongFosterStruthWeber2014, + author = {Armstrong, A. and Foster, S. and Struth, G. and Weber, T.}, + title = {Relation Algebra}, + journal = afp, + year = 2014, + note = {} +} + +@Article{BerghammerFurusawaGuttmannHoefner2020, + author = {Berghammer, R. and Furusawa, H. and Guttmann, W. and H{\"o}fner, P.}, + title = {Relational Characterisations of Paths}, + journal = jlamp, + year = 2020, + note = {To appear} +} + +@Book{Diestel2005, + author = {Diestel, R.}, + title = {Graph Theory}, + publisher = sv, + edition = {Third}, + year = 2005, + note = {} +} + +@Article{Guttmann2017a, + author = {Guttmann, W.}, + title = {Stone Relation Algebras}, + journal = afp, + year = 2017, + note = {} +} + +@Article{Guttmann2017c, + author = {Guttmann, W.}, + title = {Stone-{Kleene} Relation Algebras}, + journal = afp, + year = 2017, + note = {} +} + +@Article{Guttmann2018b, + author = {Guttmann, W.}, + title = {An Algebraic Framework for Minimum Spanning Tree Problems}, + journal = tcs, + volume = 744, + pages = {37--55}, + year = 2018, + note = {} +} + +@Article{Guttmann2018c, + author = {Guttmann, W.}, + title = {Verifying Minimum Spanning Tree Algorithms with {Stone} Relation Algebras}, + journal = jlamp, + volume = 101, + pages = {132--150}, + year = 2018, + note = {} +} + +@Article{Kozen1994, + author = {Kozen, D.}, + title = {A completeness theorem for {Kleene} algebras and the algebra of regular events}, + journal = {Information and Computation}, + volume = 110, + number = 2, + pages = {366--390}, + year = 1994, + note = {} +} + +@PhDThesis{Ng1984, + author = {Ng, K. C.}, + title = {Relation Algebras with Transitive Closure}, + school = {University of California, Berkeley}, + year = 1984, + note = {} +} + +@Book{SchmidtStroehlein1993, + author = {Schmidt, G. and Str{\"o}hlein, T.}, + title = {Relations and Graphs}, + publisher = sv, + year = 1993, + note = {} +} + +@Article{Tarski1941, + author = {Tarski, A.}, + title = {On the calculus of relations}, + journal = jsl, + volume = 6, + number = 3, + pages = {73--89}, + year = 1941, + note = {} +} + +@Book{Tinhofer1976, + author = {Tinhofer, G.}, + title = {Methoden der angewandten Graphentheorie}, + publisher = sv, + year = 1976, + note = {} +} + diff --git a/thys/Relational_Paths/document/root.tex b/thys/Relational_Paths/document/root.tex new file mode 100644 --- /dev/null +++ b/thys/Relational_Paths/document/root.tex @@ -0,0 +1,51 @@ +\documentclass[11pt,a4paper]{article} + +\usepackage{isabelle,isabellesym} +\usepackage{amssymb,ragged2e} +\usepackage{pdfsetup} + +\isabellestyle{it} +\renewenvironment{isamarkuptext}{\par\isastyletext\begin{isapar}\justifying\color{blue}}{\end{isapar}} +\renewcommand\labelitemi{$*$} + +\begin{document} + +\title{Relational Characterisations of Paths} +\author{Walter Guttmann and Peter H\"ofner} +\maketitle + +\begin{abstract} + Binary relations are one of the standard ways to encode, characterise and reason about graphs. + Relation algebras provide equational axioms for a large fragment of the calculus of binary relations. + Although relations are standard tools in many areas of mathematics and computing, researchers usually fall back to point-wise reasoning when it comes to arguments about paths in a graph. + We present a purely algebraic way to specify different kinds of paths in Kleene relation algebras, which are relation algebras equipped with an operation for reflexive transitive closure. + We study the relationship between paths with a designated root vertex and paths without such a vertex. + Since we stay in first-order logic this development helps with mechanising proofs. + To demonstrate the applicability of the algebraic framework we verify the correctness of three basic graph algorithms. +\end{abstract} + +\tableofcontents + +\section*{Overview} + +A path in a graph can be defined as a connected subgraph of edges where each vertex has at most one incoming edge and at most one outgoing edge \cite{Diestel2005,Tinhofer1976}. +We develop a theory of paths based on this representation and use it for algorithm verification. +All reasoning is done in variants of relation algebras and Kleene algebras \cite{Kozen1994,Ng1984,Tarski1941}. + +Section 1 presents fundamental results that hold in relation algebras. +Relation-algebraic characterisations of various kinds of paths are introduced and compared in Section 2. +We extend this to paths with a designated root in Section 3. +Section 4 verifies the correctness of a few basic graph algorithms. + +These Isabelle/HOL theories formally verify results in \cite{BerghammerFurusawaGuttmannHoefner2020}. +See this paper for further details and related work. + +\begin{flushleft} +\input{session} +\end{flushleft} + +\bibliographystyle{abbrv} +\bibliography{root} + +\end{document} + diff --git a/web/entries/Aggregation_Algebras.html b/web/entries/Aggregation_Algebras.html --- a/web/entries/Aggregation_Algebras.html +++ b/web/entries/Aggregation_Algebras.html @@ -1,197 +1,199 @@ Aggregation Algebras - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Aggregation Algebras

 

- + + +
Title: Aggregation Algebras
Author: Walter Guttmann
Submission date: 2018-09-15
Abstract: We develop algebras for aggregation and minimisation for weight matrices and for edge weights in graphs. We verify the correctness of Prim's and Kruskal's minimum spanning tree algorithms based on these algebras. We also show numerous instances of these algebras based on linearly ordered commutative semigroups.
BibTeX: 
@article{Aggregation_Algebras-AFP,
   author  = {Walter Guttmann},
   title   = {Aggregation Algebras},
   journal = {Archive of Formal Proofs},
   month   = sep,
   year    = 2018,
   note    = {\url{http://isa-afp.org/entries/Aggregation_Algebras.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Depends on: Stone_Kleene_Relation_Algebras
Used by:Relational_Disjoint_Set_Forests, Relational_Paths

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/entries/Amicable_Numbers.html b/web/entries/Amicable_Numbers.html new file mode 100644 --- /dev/null +++ b/web/entries/Amicable_Numbers.html @@ -0,0 +1,186 @@ + + + + +Amicable Numbers - Archive of Formal Proofs + + + + + + + + + + + + + + + + + + + + + + + + +
+

 

+ + + +

 

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download
+

 

+

 

+		 +
+

 

+

Amicable + + Numbers + +

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Title:Amicable Numbers
+ Author: + + Angeliki Koutsoukou-Argyraki +
Submission date:2020-08-04
Abstract: +This is a formalisation of Amicable Numbers, involving some relevant +material including Euler's sigma function, some relevant +definitions, results and examples as well as rules such as +Thābit ibn Qurra's Rule, Euler's Rule, te +Riele's Rule and Borho's Rule with breeders.
BibTeX: + 
@article{Amicable_Numbers-AFP,
+  author  = {Angeliki Koutsoukou-Argyraki},
+  title   = {Amicable Numbers},
+  journal = {Archive of Formal Proofs},
+  month   = aug,
+  year    = 2020,
+  note    = {\url{http://isa-afp.org/entries/Amicable_Numbers.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
License:BSD License
Depends on:Polynomial_Factorization, Pratt_Certificate
+ +

+ + + + + + + + + + + + + + + + +
+ Proof outline
+ Proof document +
+ Browse theories +
+ Download this entry +
Older releases: + None +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/web/entries/Chandy_Lamport.html b/web/entries/Chandy_Lamport.html new file mode 100644 --- /dev/null +++ b/web/entries/Chandy_Lamport.html @@ -0,0 +1,201 @@ + + + + +A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm - Archive of Formal Proofs + + + + + + + + + + + + + + + + + + + + + + + + +
+

 

+ + + +

 

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download
+

 

+

 

+		 +
+

 

+

A + + Formal + + Proof + + of + + The + + Chandy--Lamport + + Distributed + + Snapshot + + Algorithm + +

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Title:A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm
+ Authors: + + Ben Fiedler (ben /dot/ fiedler /at/ inf /dot/ ethz /dot/ ch) and + Dmitriy Traytel +
Submission date:2020-07-21
Abstract: +We provide a suitable distributed system model and implementation of the +Chandy--Lamport distributed snapshot algorithm [ACM Transactions on +Computer Systems, 3, 63-75, 1985]. Our main result is a formal +termination and correctness proof of the Chandy--Lamport algorithm and +its use in stable property detection.
BibTeX: + 
@article{Chandy_Lamport-AFP,
+  author  = {Ben Fiedler and Dmitriy Traytel},
+  title   = {A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm},
+  journal = {Archive of Formal Proofs},
+  month   = jul,
+  year    = 2020,
+  note    = {\url{http://isa-afp.org/entries/Chandy_Lamport.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
License:BSD License
Depends on:Ordered_Resolution_Prover
+ +

+ + + + + + + + + + + + + + + + +
+ Proof outline
+ Proof document +
+ Browse theories +
+ Download this entry +
Older releases: + None +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/web/entries/Nash_Williams.html b/web/entries/Nash_Williams.html --- a/web/entries/Nash_Williams.html +++ b/web/entries/Nash_Williams.html @@ -1,189 +1,191 @@ The Nash-Williams Partition Theorem - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

The Nash-Williams Partition Theorem

 

- + + +
Title: The Nash-Williams Partition Theorem
Author: Lawrence C. Paulson
Submission date: 2020-05-16
Abstract: In 1965, Nash-Williams discovered a generalisation of the infinite form of Ramsey's theorem. Where the latter concerns infinite sets of n-element sets for some fixed n, the Nash-Williams theorem concerns infinite sets of finite sets (or lists) subject to a “no initial segment” condition. The present formalisation follows a monograph on Ramsey Spaces by Todorčević.
BibTeX: 
@article{Nash_Williams-AFP,
   author  = {Lawrence C. Paulson},
   title   = {The Nash-Williams Partition Theorem},
   journal = {Archive of Formal Proofs},
   month   = may,
   year    = 2020,
   note    = {\url{http://isa-afp.org/entries/Nash_Williams.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Used by:Ordinal_Partitions

Proof outline
Proof document
Browse theories
Download this entry
Older releases: None
\ No newline at end of file diff --git a/web/entries/Ordered_Resolution_Prover.html b/web/entries/Ordered_Resolution_Prover.html --- a/web/entries/Ordered_Resolution_Prover.html +++ b/web/entries/Ordered_Resolution_Prover.html @@ -1,221 +1,221 @@ Formalization of Bachmair and Ganzinger's Ordered Resolution Prover - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Formalization of Bachmair and Ganzinger's Ordered Resolution Prover

 

- +
Title: Formalization of Bachmair and Ganzinger's Ordered Resolution Prover
Authors: Anders Schlichtkrull, Jasmin Christian Blanchette (j /dot/ c /dot/ blanchette /at/ vu /dot/ nl), Dmitriy Traytel and Uwe Waldmann (uwe /at/ mpi-inf /dot/ mpg /dot/ de)
Submission date: 2018-01-18
Abstract: This Isabelle/HOL formalization covers Sections 2 to 4 of Bachmair and Ganzinger's "Resolution Theorem Proving" chapter in the Handbook of Automated Reasoning. This includes soundness and completeness of unordered and ordered variants of ground resolution with and without literal selection, the standard redundancy criterion, a general framework for refutational theorem proving, and soundness and completeness of an abstract first-order prover.
BibTeX: 
@article{Ordered_Resolution_Prover-AFP,
   author  = {Anders Schlichtkrull and Jasmin Christian Blanchette and Dmitriy Traytel and Uwe Waldmann},
   title   = {Formalization of Bachmair and Ganzinger's Ordered Resolution Prover},
   journal = {Archive of Formal Proofs},
   month   = jan,
   year    = 2018,
   note    = {\url{http://isa-afp.org/entries/Ordered_Resolution_Prover.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Depends on: Coinductive, Nested_Multisets_Ordinals
Used by:Functional_Ordered_Resolution_Prover, Saturation_Framework, Saturation_Framework_Extensions
Chandy_Lamport, Functional_Ordered_Resolution_Prover, Saturation_Framework, Saturation_Framework_Extensions

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/entries/Ordinal_Partitions.html b/web/entries/Ordinal_Partitions.html new file mode 100644 --- /dev/null +++ b/web/entries/Ordinal_Partitions.html @@ -0,0 +1,197 @@ + + + + +Ordinal Partitions - Archive of Formal Proofs + + + + + + + + + + + + + + + + + + + + + + + + +
+

 

+ + + +

 

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download
+

 

+

 

+		 +
+

 

+

Ordinal + + Partitions + +

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Title:Ordinal Partitions
+ Author: + + Lawrence C. Paulson +
Submission date:2020-08-03
Abstract: +The theory of partition relations concerns generalisations of +Ramsey's theorem. For any ordinal $\alpha$, write $\alpha \to +(\alpha, m)^2$ if for each function $f$ from unordered pairs of +elements of $\alpha$ into $\{0,1\}$, either there is a subset +$X\subseteq \alpha$ order-isomorphic to $\alpha$ such that +$f\{x,y\}=0$ for all $\{x,y\}\subseteq X$, or there is an $m$ element +set $Y\subseteq \alpha$ such that $f\{x,y\}=1$ for all +$\{x,y\}\subseteq Y$. (In both cases, with $\{x,y\}$ we require +$x\not=y$.) In particular, the infinite Ramsey theorem can be written +in this notation as $\omega \to (\omega, \omega)^2$, or if we +restrict $m$ to the positive integers as above, then $\omega \to +(\omega, m)^2$ for all $m$. This entry formalises Larson's proof +of $\omega^\omega \to (\omega^\omega, m)^2$ along with a similar proof +of a result due to Specker: $\omega^2 \to (\omega^2, m)^2$. Also +proved is a necessary result by Erdős and Milner: +$\omega^{1+\alpha\cdot n} \to (\omega^{1+\alpha}, 2^n)^2$.
BibTeX: + 
@article{Ordinal_Partitions-AFP,
+  author  = {Lawrence C. Paulson},
+  title   = {Ordinal Partitions},
+  journal = {Archive of Formal Proofs},
+  month   = aug,
+  year    = 2020,
+  note    = {\url{http://isa-afp.org/entries/Ordinal_Partitions.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
License:BSD License
Depends on:Nash_Williams, ZFC_in_HOL
+ +

+ + + + + + + + + + + + + + + + +
+ Proof outline
+ Proof document +
+ Browse theories +
+ Download this entry +
Older releases: + None +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/web/entries/Polynomial_Factorization.html b/web/entries/Polynomial_Factorization.html --- a/web/entries/Polynomial_Factorization.html +++ b/web/entries/Polynomial_Factorization.html @@ -1,224 +1,224 @@ Polynomial Factorization - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Polynomial Factorization

 

- +
Title: Polynomial Factorization
Authors: René Thiemann and Akihisa Yamada
Submission date: 2016-01-29
Abstract: Based on existing libraries for polynomial interpolation and matrices, we formalized several factorization algorithms for polynomials, including Kronecker's algorithm for integer polynomials, Yun's square-free factorization algorithm for field polynomials, and Berlekamp's algorithm for polynomials over finite fields. By combining the last one with Hensel's lifting, we derive an efficient factorization algorithm for the integer polynomials, which is then lifted for rational polynomials by mechanizing Gauss' lemma. Finally, we assembled a combined factorization algorithm for rational polynomials, which combines all the mentioned algorithms and additionally uses the explicit formula for roots of quadratic polynomials and a rational root test.

As side products, we developed division algorithms for polynomials over integral domains, as well as primality-testing and prime-factorization algorithms for integers.
BibTeX: 
@article{Polynomial_Factorization-AFP,
   author  = {René Thiemann and Akihisa Yamada},
   title   = {Polynomial Factorization},
   journal = {Archive of Formal Proofs},
   month   = jan,
   year    = 2016,
   note    = {\url{http://isa-afp.org/entries/Polynomial_Factorization.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Depends on: Partial_Function_MR, Polynomial_Interpolation, Show, Sqrt_Babylonian
Used by:Dirichlet_Series, Functional_Ordered_Resolution_Prover, Gaussian_Integers, Jordan_Normal_Form, Knuth_Bendix_Order, Linear_Recurrences, Perron_Frobenius, Power_Sum_Polynomials, Subresultants
Amicable_Numbers, Dirichlet_Series, Functional_Ordered_Resolution_Prover, Gaussian_Integers, Jordan_Normal_Form, Knuth_Bendix_Order, Linear_Recurrences, Perron_Frobenius, Power_Sum_Polynomials, Subresultants

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/entries/Pratt_Certificate.html b/web/entries/Pratt_Certificate.html --- a/web/entries/Pratt_Certificate.html +++ b/web/entries/Pratt_Certificate.html @@ -1,237 +1,237 @@ Pratt's Primality Certificates - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Pratt's Primality Certificates

 

- +
Title: Pratt's Primality Certificates
Authors: Simon Wimmer and Lars Noschinski
Submission date: 2013-07-22
Abstract: In 1975, Pratt introduced a proof system for certifying primes. He showed that a number p is prime iff a primality certificate for p exists. By showing a logarithmic upper bound on the length of the certificates in size of the prime number, he concluded that the decision problem for prime numbers is in NP. This work formalizes soundness and completeness of Pratt's proof system as well as an upper bound for the size of the certificate.
BibTeX: 
@article{Pratt_Certificate-AFP,
   author  = {Simon Wimmer and Lars Noschinski},
   title   = {Pratt's Primality Certificates},
   journal = {Archive of Formal Proofs},
   month   = jul,
   year    = 2013,
   note    = {\url{http://isa-afp.org/entries/Pratt_Certificate.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Depends on: Lehmer
Used by:Bertrands_Postulate
Amicable_Numbers, Bertrands_Postulate

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/entries/Relation_Algebra.html b/web/entries/Relation_Algebra.html --- a/web/entries/Relation_Algebra.html +++ b/web/entries/Relation_Algebra.html @@ -1,238 +1,238 @@ Relation Algebra - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Relation Algebra

 

- +
Title: Relation Algebra
Authors: Alasdair Armstrong, Simon Foster, Georg Struth and Tjark Weber (tjark /dot/ weber /at/ it /dot/ uu /dot/ se)
Submission date: 2014-01-25
Abstract: Tarski's algebra of binary relations is formalised along the lines of the standard textbooks of Maddux and Schmidt and Ströhlein. This includes relation-algebraic concepts such as subidentities, vectors and a domain operation as well as various notions associated to functions. Relation algebras are also expanded by a reflexive transitive closure operation, and they are linked with Kleene algebras and models of binary relations and Boolean matrices.
BibTeX: 
@article{Relation_Algebra-AFP,
   author  = {Alasdair Armstrong and Simon Foster and Georg Struth and Tjark Weber},
   title   = {Relation Algebra},
   journal = {Archive of Formal Proofs},
   month   = jan,
   year    = 2014,
   note    = {\url{http://isa-afp.org/entries/Relation_Algebra.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Depends on: Kleene_Algebra
Used by:Residuated_Lattices
Relational_Paths, Residuated_Lattices

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/entries/Relational_Disjoint_Set_Forests.html b/web/entries/Relational_Disjoint_Set_Forests.html new file mode 100644 --- /dev/null +++ b/web/entries/Relational_Disjoint_Set_Forests.html @@ -0,0 +1,189 @@ + + + + +Relational Disjoint-Set Forests - Archive of Formal Proofs + + + + + + + + + + + + + + + + + + + + + + + + +
+

 

+ + + +

 

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download
+

 

+

 

+		 +
+

 

+

Relational + + Disjoint-Set + + Forests + +

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Title:Relational Disjoint-Set Forests
+ Author: + + Walter Guttmann +
Submission date:2020-08-26
Abstract: +We give a simple relation-algebraic semantics of read and write +operations on associative arrays. The array operations seamlessly +integrate with assignments in the Hoare-logic library. Using relation +algebras and Kleene algebras we verify the correctness of an +array-based implementation of disjoint-set forests with a naive union +operation and a find operation with path compression.
BibTeX: + 
@article{Relational_Disjoint_Set_Forests-AFP,
+  author  = {Walter Guttmann},
+  title   = {Relational Disjoint-Set Forests},
+  journal = {Archive of Formal Proofs},
+  month   = aug,
+  year    = 2020,
+  note    = {\url{http://isa-afp.org/entries/Relational_Disjoint_Set_Forests.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
License:BSD License
Depends on:Aggregation_Algebras, Stone_Kleene_Relation_Algebras
+ +

+ + + + + + + + + + + + + + + + +
+ Proof outline
+ Proof document +
+ Browse theories +
+ Download this entry +
Older releases: + None +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/web/entries/Relational_Paths.html b/web/entries/Relational_Paths.html new file mode 100644 --- /dev/null +++ b/web/entries/Relational_Paths.html @@ -0,0 +1,199 @@ + + + + +Relational Characterisations of Paths - Archive of Formal Proofs + + + + + + + + + + + + + + + + + + + + + + + + +
+

 

+ + + +

 

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download
+

 

+

 

+		 +
+

 

+

Relational + + Characterisations + + of + + Paths + +

+

 

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Title:Relational Characterisations of Paths
+ Authors: + + Walter Guttmann and + Peter Höfner +
Submission date:2020-07-13
Abstract: +Binary relations are one of the standard ways to encode, characterise +and reason about graphs. Relation algebras provide equational axioms +for a large fragment of the calculus of binary relations. Although +relations are standard tools in many areas of mathematics and +computing, researchers usually fall back to point-wise reasoning when +it comes to arguments about paths in a graph. We present a purely +algebraic way to specify different kinds of paths in Kleene relation +algebras, which are relation algebras equipped with an operation for +reflexive transitive closure. We study the relationship between paths +with a designated root vertex and paths without such a vertex. Since +we stay in first-order logic this development helps with mechanising +proofs. To demonstrate the applicability of the algebraic framework we +verify the correctness of three basic graph algorithms.
BibTeX: + 
@article{Relational_Paths-AFP,
+  author  = {Walter Guttmann and Peter Höfner},
+  title   = {Relational Characterisations of Paths},
+  journal = {Archive of Formal Proofs},
+  month   = jul,
+  year    = 2020,
+  note    = {\url{http://isa-afp.org/entries/Relational_Paths.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
License:BSD License
Depends on:Aggregation_Algebras, Relation_Algebra
+ +

+ + + + + + + + + + + + + + + + +
+ Proof outline
+ Proof document +
+ Browse theories +
+ Download this entry +
Older releases: + None +
+ +
+
+ + + + + + \ No newline at end of file diff --git a/web/entries/Stone_Kleene_Relation_Algebras.html b/web/entries/Stone_Kleene_Relation_Algebras.html --- a/web/entries/Stone_Kleene_Relation_Algebras.html +++ b/web/entries/Stone_Kleene_Relation_Algebras.html @@ -1,210 +1,210 @@ Stone-Kleene Relation Algebras - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Stone-Kleene Relation Algebras

 

- +
Title: Stone-Kleene Relation Algebras
Author: Walter Guttmann
Submission date: 2017-07-06
Abstract: We develop Stone-Kleene relation algebras, which expand Stone relation algebras with a Kleene star operation to describe reachability in weighted graphs. Many properties of the Kleene star arise as a special case of a more general theory of iteration based on Conway semirings extended by simulation axioms. This includes several theorems representing complex program transformations. We formally prove the correctness of Conway's automata-based construction of the Kleene star of a matrix. We prove numerous results useful for reasoning about weighted graphs.
BibTeX: 
@article{Stone_Kleene_Relation_Algebras-AFP,
   author  = {Walter Guttmann},
   title   = {Stone-Kleene Relation Algebras},
   journal = {Archive of Formal Proofs},
   month   = jul,
   year    = 2017,
   note    = {\url{http://isa-afp.org/entries/Stone_Kleene_Relation_Algebras.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Depends on: Stone_Relation_Algebras
Used by:Aggregation_Algebras
Aggregation_Algebras, Relational_Disjoint_Set_Forests

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/entries/ZFC_in_HOL.html b/web/entries/ZFC_in_HOL.html --- a/web/entries/ZFC_in_HOL.html +++ b/web/entries/ZFC_in_HOL.html @@ -1,221 +1,223 @@ Zermelo Fraenkel Set Theory in Higher-Order Logic - Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Zermelo Fraenkel Set Theory in Higher-Order Logic

 

- + + +
Title: Zermelo Fraenkel Set Theory in Higher-Order Logic
Author: Lawrence C. Paulson
Submission date: 2019-10-24
Abstract:

This entry is a new formalisation of ZFC set theory in Isabelle/HOL. It is logically equivalent to Obua's HOLZF; the point is to have the closest possible integration with the rest of Isabelle/HOL, minimising the amount of new notations and exploiting type classes.

There is a type V of sets and a function elts :: V => V set mapping a set to its elements. Classes simply have type V set, and a predicate identifies the small classes: those that correspond to actual sets. Type classes connected with orders and lattices are used to minimise the amount of new notation for concepts such as the subset relation, union and intersection. Basic concepts — Cartesian products, disjoint sums, natural numbers, functions, etc. — are formalised.

More advanced set-theoretic concepts, such as transfinite induction, ordinals, cardinals and the transitive closure of a set, are also provided. The definition of addition and multiplication for general sets (not just ordinals) follows Kirby.

The theory provides two type classes with the aim of facilitating developments that combine V with other Isabelle/HOL types: embeddable, the class of types that can be injected into V (including V itself as well as V*V, etc.), and small, the class of types that correspond to some ZF set.

extra-history = Change history: [2020-01-28]: Generalisation of the "small" predicate and order types to arbitrary sets; ordinal exponentiation; introduction of the coercion ord_of_nat :: "nat => V"; numerous new lemmas. (revision 6081d5be8d08)
BibTeX: 
@article{ZFC_in_HOL-AFP,
   author  = {Lawrence C. Paulson},
   title   = {Zermelo Fraenkel Set Theory in Higher-Order Logic},
   journal = {Archive of Formal Proofs},
   month   = oct,
   year    = 2019,
   note    = {\url{http://isa-afp.org/entries/ZFC_in_HOL.html},
             Formal proof development},
   ISSN    = {2150-914x},
 }
License: BSD License
Used by:Ordinal_Partitions

Proof outline
Proof document
Browse theories
Download this entry
Older releases:
\ No newline at end of file diff --git a/web/index.html b/web/index.html --- a/web/index.html +++ b/web/index.html @@ -1,5016 +1,5058 @@ Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Archive of Formal Proofs

 

The Archive of Formal Proofs is a collection of proof libraries, examples, and larger scientific developments, mechanically checked in the theorem prover Isabelle. It is organized in the way of a scientific journal, is indexed by dblp and has an ISSN: 2150-914x. Submissions are refereed. The preferred citation style is available [here]. We encourage companion AFP submissions to conference and journal publications.

A development version of the archive is available as well.

 

 

+ + + + + + + + + + + + + + +
2020
+ 2020-08-26: Relational Disjoint-Set Forests +
+ Author: + Walter Guttmann +
2020-08-25: Extensions to the Comprehensive Framework for Saturation Theorem Proving
Authors: Jasmin Blanchette and Sophie Tourret
+ 2020-08-04: Amicable Numbers +
+ Author: + Angeliki Koutsoukou-Argyraki +
+ 2020-08-03: Ordinal Partitions +
+ Author: + Lawrence C. Paulson +
+ 2020-07-21: A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm +
+ Authors: + Ben Fiedler + and Dmitriy Traytel +
+ 2020-07-13: Relational Characterisations of Paths +
+ Authors: + Walter Guttmann + and Peter Höfner +
2020-06-01: A Formally Verified Checker of the Safe Distance Traffic Rules for Autonomous Vehicles
Authors: Albert Rizaldi and Fabian Immler
2020-05-23: A verified algorithm for computing the Smith normal form of a matrix
Author: Jose Divasón
2020-05-16: The Nash-Williams Partition Theorem
Author: Lawrence C. Paulson
2020-05-13: A Formalization of Knuth–Bendix Orders
Authors: Christian Sternagel and René Thiemann
2020-05-12: Irrationality Criteria for Series by Erdős and Straus
Authors: Angeliki Koutsoukou-Argyraki and Wenda Li
2020-05-11: Recursion Theorem in ZF
Author: Georgy Dunaev
2020-05-08: An Efficient Normalisation Procedure for Linear Temporal Logic: Isabelle/HOL Formalisation
Author: Salomon Sickert
2020-05-06: Formalization of Forcing in Isabelle/ZF
Authors: Emmanuel Gunther, Miguel Pagano and Pedro Sánchez Terraf
2020-05-02: Banach-Steinhaus Theorem
Authors: Dominique Unruh and Jose Manuel Rodriguez Caballero
2020-04-27: Attack Trees in Isabelle for GDPR compliance of IoT healthcare systems
Author: Florian Kammueller
2020-04-24: Power Sum Polynomials
Author: Manuel Eberl
2020-04-24: The Lambert W Function on the Reals
Author: Manuel Eberl
2020-04-24: Gaussian Integers
Author: Manuel Eberl
2020-04-19: Matrices for ODEs
Author: Jonathan Julian Huerta y Munive
2020-04-16: Authenticated Data Structures As Functors
Authors: Andreas Lochbihler and Ognjen Marić
2020-04-10: Formalization of an Algorithm for Greedily Computing Associative Aggregations on Sliding Windows
Authors: Lukas Heimes, Dmitriy Traytel and Joshua Schneider
2020-04-09: A Comprehensive Framework for Saturation Theorem Proving
Author: Sophie Tourret
2020-04-09: Formalization of an Optimized Monitoring Algorithm for Metric First-Order Dynamic Logic with Aggregations
Authors: Thibault Dardinier, Lukas Heimes, Martin Raszyk, Joshua Schneider and Dmitriy Traytel
2020-04-08: Stateful Protocol Composition and Typing
Authors: Andreas V. Hess, Sebastian Mödersheim and Achim D. Brucker
2020-04-08: Automated Stateful Protocol Verification
Authors: Andreas V. Hess, Sebastian Mödersheim, Achim D. Brucker and Anders Schlichtkrull
2020-04-07: Lucas's Theorem
Author: Chelsea Edmonds
2020-03-25: Strong Eventual Consistency of the Collaborative Editing Framework WOOT
Authors: Emin Karayel and Edgar Gonzàlez
2020-03-22: Furstenberg's topology and his proof of the infinitude of primes
Author: Manuel Eberl
2020-03-12: An Under-Approximate Relational Logic
Author: Toby Murray
2020-03-07: Hello World
Authors: Cornelius Diekmann and Lars Hupel
2020-02-21: Implementing the Goodstein Function in λ-Calculus
Author: Bertram Felgenhauer
2020-02-10: A Generic Framework for Verified Compilers
Author: Martin Desharnais
2020-02-01: Arithmetic progressions and relative primes
Author: José Manuel Rodríguez Caballero
2020-01-31: A Hierarchy of Algebras for Boolean Subsets
Authors: Walter Guttmann and Bernhard Möller
2020-01-17: Mersenne primes and the Lucas–Lehmer test
Author: Manuel Eberl
2020-01-16: Verified Approximation Algorithms
Authors: Robin Eßmann, Tobias Nipkow and Simon Robillard
2020-01-13: Closest Pair of Points Algorithms
Authors: Martin Rau and Tobias Nipkow
2020-01-09: Skip Lists
Authors: Max W. Haslbeck and Manuel Eberl
2020-01-06: Bicategories
Author: Eugene W. Stark

 

2019
2019-12-27: The Irrationality of ζ(3)
Author: Manuel Eberl
2019-12-20: Formalizing a Seligman-Style Tableau System for Hybrid Logic
Author: Asta Halkjær From
2019-12-18: The Poincaré-Bendixson Theorem
Authors: Fabian Immler and Yong Kiam Tan
2019-12-16: Poincaré Disc Model
Authors: Danijela Simić, Filip Marić and Pierre Boutry
2019-12-16: Complex Geometry
Authors: Filip Marić and Danijela Simić
2019-12-10: Gauss Sums and the Pólya–Vinogradov Inequality
Authors: Rodrigo Raya and Manuel Eberl
2019-12-04: An Efficient Generalization of Counting Sort for Large, possibly Infinite Key Ranges
Author: Pasquale Noce
2019-11-27: Interval Arithmetic on 32-bit Words
Author: Brandon Bohrer
2019-10-24: Zermelo Fraenkel Set Theory in Higher-Order Logic
Author: Lawrence C. Paulson
2019-10-22: Isabelle/C
Authors: Frédéric Tuong and Burkhart Wolff
2019-10-16: VerifyThis 2019 -- Polished Isabelle Solutions
Authors: Peter Lammich and Simon Wimmer
2019-10-08: Aristotle's Assertoric Syllogistic
Author: Angeliki Koutsoukou-Argyraki
2019-10-07: Sigma Protocols and Commitment Schemes
Authors: David Butler and Andreas Lochbihler
2019-10-04: Clean - An Abstract Imperative Programming Language and its Theory
Authors: Frédéric Tuong and Burkhart Wolff
2019-09-16: Formalization of Multiway-Join Algorithms
Author: Thibault Dardinier
2019-09-10: Verification Components for Hybrid Systems
Author: Jonathan Julian Huerta y Munive
2019-09-06: Fourier Series
Author: Lawrence C Paulson
2019-08-30: A Case Study in Basic Algebra
Author: Clemens Ballarin
2019-08-16: Formalisation of an Adaptive State Counting Algorithm
Author: Robert Sachtleben
2019-08-14: Laplace Transform
Author: Fabian Immler
2019-08-06: Linear Programming
Authors: Julian Parsert and Cezary Kaliszyk
2019-08-06: Communicating Concurrent Kleene Algebra for Distributed Systems Specification
Authors: Maxime Buyse and Jason Jaskolka
2019-08-05: Selected Problems from the International Mathematical Olympiad 2019
Author: Manuel Eberl
2019-08-01: Stellar Quorum Systems
Author: Giuliano Losa
2019-07-30: A Formal Development of a Polychronous Polytimed Coordination Language
Authors: Hai Nguyen Van, Frédéric Boulanger and Burkhart Wolff
2019-07-27: Szpilrajn Extension Theorem
Author: Peter Zeller
2019-07-18: A Sequent Calculus for First-Order Logic
Author: Asta Halkjær From
2019-07-08: A Verified Code Generator from Isabelle/HOL to CakeML
Author: Lars Hupel
2019-07-04: Formalization of a Monitoring Algorithm for Metric First-Order Temporal Logic
Authors: Joshua Schneider and Dmitriy Traytel
2019-06-27: Complete Non-Orders and Fixed Points
Authors: Akihisa Yamada and Jérémy Dubut
2019-06-25: Priority Search Trees
Authors: Peter Lammich and Tobias Nipkow
2019-06-25: Purely Functional, Simple, and Efficient Implementation of Prim and Dijkstra
Authors: Peter Lammich and Tobias Nipkow
2019-06-21: Linear Inequalities
Authors: Ralph Bottesch, Alban Reynaud and René Thiemann
2019-06-16: Hilbert's Nullstellensatz
Author: Alexander Maletzky
2019-06-15: Gröbner Bases, Macaulay Matrices and Dubé's Degree Bounds
Author: Alexander Maletzky
2019-06-13: Binary Heaps for IMP2
Author: Simon Griebel
2019-06-03: Differential Game Logic
Author: André Platzer
2019-05-30: Multidimensional Binary Search Trees
Author: Martin Rau
2019-05-14: Formalization of Generic Authenticated Data Structures
Authors: Matthias Brun and Dmitriy Traytel
2019-05-09: Multi-Party Computation
Authors: David Aspinall and David Butler
2019-04-26: HOL-CSP Version 2.0
Authors: Safouan Taha, Lina Ye and Burkhart Wolff
2019-04-16: A Compositional and Unified Translation of LTL into ω-Automata
Authors: Benedikt Seidl and Salomon Sickert
2019-04-06: A General Theory of Syntax with Bindings
Authors: Lorenzo Gheri and Andrei Popescu
2019-03-27: The Transcendence of Certain Infinite Series
Authors: Angeliki Koutsoukou-Argyraki and Wenda Li
2019-03-24: Quantum Hoare Logic
Authors: Junyi Liu, Bohua Zhan, Shuling Wang, Shenggang Ying, Tao Liu, Yangjia Li, Mingsheng Ying and Naijun Zhan
2019-03-09: Safe OCL
Author: Denis Nikiforov
2019-02-21: Elementary Facts About the Distribution of Primes
Author: Manuel Eberl
2019-02-14: Kruskal's Algorithm for Minimum Spanning Forest
Authors: Maximilian P.L. Haslbeck, Peter Lammich and Julian Biendarra
2019-02-11: Probabilistic Primality Testing
Authors: Daniel Stüwe and Manuel Eberl
2019-02-08: Universal Turing Machine
Authors: Jian Xu, Xingyuan Zhang, Christian Urban and Sebastiaan J. C. Joosten
2019-02-01: Isabelle/UTP: Mechanised Theory Engineering for Unifying Theories of Programming
Authors: Simon Foster, Frank Zeyda, Yakoub Nemouchi, Pedro Ribeiro and Burkhart Wolff
2019-02-01: The Inversions of a List
Author: Manuel Eberl
2019-01-17: Farkas' Lemma and Motzkin's Transposition Theorem
Authors: Ralph Bottesch, Max W. Haslbeck and René Thiemann
2019-01-15: IMP2 – Simple Program Verification in Isabelle/HOL
Authors: Peter Lammich and Simon Wimmer
2019-01-15: An Algebra for Higher-Order Terms
Author: Lars Hupel
2019-01-07: A Reduction Theorem for Store Buffers
Authors: Ernie Cohen and Norbert Schirmer

 

2018
2018-12-26: A Formal Model of the Document Object Model
Authors: Achim D. Brucker and Michael Herzberg
2018-12-25: Formalization of Concurrent Revisions
Author: Roy Overbeek
2018-12-21: Verifying Imperative Programs using Auto2
Author: Bohua Zhan
2018-12-17: Constructive Cryptography in HOL
Authors: Andreas Lochbihler and S. Reza Sefidgar
2018-12-11: Transformer Semantics
Author: Georg Struth
2018-12-11: Quantales
Author: Georg Struth
2018-12-11: Properties of Orderings and Lattices
Author: Georg Struth
2018-11-23: Graph Saturation
Author: Sebastiaan J. C. Joosten
2018-11-23: A Verified Functional Implementation of Bachmair and Ganzinger's Ordered Resolution Prover
Authors: Anders Schlichtkrull, Jasmin Christian Blanchette and Dmitriy Traytel
2018-11-20: Auto2 Prover
Author: Bohua Zhan
2018-11-16: Matroids
Author: Jonas Keinholz
2018-11-06: Deriving generic class instances for datatypes
Authors: Jonas Rädle and Lars Hupel
2018-10-30: Formalisation and Evaluation of Alan Gewirth's Proof for the Principle of Generic Consistency in Isabelle/HOL
Authors: David Fuenmayor and Christoph Benzmüller
2018-10-29: Epistemic Logic
Author: Asta Halkjær From
2018-10-22: Smooth Manifolds
Authors: Fabian Immler and Bohua Zhan
2018-10-19: Randomised Binary Search Trees
Author: Manuel Eberl
2018-10-19: Formalization of the Embedding Path Order for Lambda-Free Higher-Order Terms
Author: Alexander Bentkamp
2018-10-12: Upper Bounding Diameters of State Spaces of Factored Transition Systems
Authors: Friedrich Kurz and Mohammad Abdulaziz
2018-09-28: The Transcendence of π
Author: Manuel Eberl
2018-09-25: Symmetric Polynomials
Author: Manuel Eberl
2018-09-20: Signature-Based Gröbner Basis Algorithms
Author: Alexander Maletzky
2018-09-19: The Prime Number Theorem
Authors: Manuel Eberl and Lawrence C. Paulson
2018-09-15: Aggregation Algebras
Author: Walter Guttmann
2018-09-14: Octonions
Author: Angeliki Koutsoukou-Argyraki
2018-09-05: Quaternions
Author: Lawrence C. Paulson
2018-09-02: The Budan-Fourier Theorem and Counting Real Roots with Multiplicity
Author: Wenda Li
2018-08-24: An Incremental Simplex Algorithm with Unsatisfiable Core Generation
Authors: Filip Marić, Mirko Spasić and René Thiemann
2018-08-14: Minsky Machines
Author: Bertram Felgenhauer
2018-07-16: Pricing in discrete financial models
Author: Mnacho Echenim
2018-07-04: Von-Neumann-Morgenstern Utility Theorem
Authors: Julian Parsert and Cezary Kaliszyk
2018-06-23: Pell's Equation
Author: Manuel Eberl
2018-06-14: Projective Geometry
Author: Anthony Bordg
2018-06-14: The Localization of a Commutative Ring
Author: Anthony Bordg
2018-06-05: Partial Order Reduction
Author: Julian Brunner
2018-05-27: Optimal Binary Search Trees
Authors: Tobias Nipkow and Dániel Somogyi
2018-05-25: Hidden Markov Models
Author: Simon Wimmer
2018-05-24: Probabilistic Timed Automata
Authors: Simon Wimmer and Johannes Hölzl
2018-05-23: Irrational Rapidly Convergent Series
Authors: Angeliki Koutsoukou-Argyraki and Wenda Li
2018-05-23: Axiom Systems for Category Theory in Free Logic
Authors: Christoph Benzmüller and Dana Scott
2018-05-22: Monadification, Memoization and Dynamic Programming
Authors: Simon Wimmer, Shuwei Hu and Tobias Nipkow
2018-05-10: OpSets: Sequential Specifications for Replicated Datatypes
Authors: Martin Kleppmann, Victor B. F. Gomes, Dominic P. Mulligan and Alastair R. Beresford
2018-05-07: An Isabelle/HOL Formalization of the Modular Assembly Kit for Security Properties
Authors: Oliver Bračevac, Richard Gay, Sylvia Grewe, Heiko Mantel, Henning Sudbrock and Markus Tasch
2018-04-29: WebAssembly
Author: Conrad Watt
2018-04-27: VerifyThis 2018 - Polished Isabelle Solutions
Authors: Peter Lammich and Simon Wimmer
2018-04-24: Bounded Natural Functors with Covariance and Contravariance
Authors: Andreas Lochbihler and Joshua Schneider
2018-03-22: The Incompatibility of Fishburn-Strategyproofness and Pareto-Efficiency
Authors: Felix Brandt, Manuel Eberl, Christian Saile and Christian Stricker
2018-03-13: Weight-Balanced Trees
Authors: Tobias Nipkow and Stefan Dirix
2018-03-12: CakeML
Authors: Lars Hupel and Yu Zhang
2018-03-01: A Theory of Architectural Design Patterns
Author: Diego Marmsoler
2018-02-26: Hoare Logics for Time Bounds
Authors: Maximilian P. L. Haslbeck and Tobias Nipkow
2018-02-06: Treaps
Authors: Maximilian Haslbeck, Manuel Eberl and Tobias Nipkow
2018-02-06: A verified factorization algorithm for integer polynomials with polynomial complexity
Authors: Jose Divasón, Sebastiaan Joosten, René Thiemann and Akihisa Yamada
2018-02-06: First-Order Terms
Authors: Christian Sternagel and René Thiemann
2018-02-06: The Error Function
Author: Manuel Eberl
2018-02-02: A verified LLL algorithm
Authors: Ralph Bottesch, Jose Divasón, Maximilian Haslbeck, Sebastiaan Joosten, René Thiemann and Akihisa Yamada
2018-01-18: Formalization of Bachmair and Ganzinger's Ordered Resolution Prover
Authors: Anders Schlichtkrull, Jasmin Christian Blanchette, Dmitriy Traytel and Uwe Waldmann
2018-01-16: Gromov Hyperbolicity
Author: Sebastien Gouezel
2018-01-11: An Isabelle/HOL formalisation of Green's Theorem
Authors: Mohammad Abdulaziz and Lawrence C. Paulson
2018-01-08: Taylor Models
Authors: Christoph Traut and Fabian Immler

 

2017
2017-12-22: The Falling Factorial of a Sum
Author: Lukas Bulwahn
2017-12-21: The Median-of-Medians Selection Algorithm
Author: Manuel Eberl
2017-12-21: The Mason–Stothers Theorem
Author: Manuel Eberl
2017-12-21: Dirichlet L-Functions and Dirichlet's Theorem
Author: Manuel Eberl
2017-12-19: Operations on Bounded Natural Functors
Authors: Jasmin Christian Blanchette, Andrei Popescu and Dmitriy Traytel
2017-12-18: The string search algorithm by Knuth, Morris and Pratt
Authors: Fabian Hellauer and Peter Lammich
2017-11-22: Stochastic Matrices and the Perron-Frobenius Theorem
Author: René Thiemann
2017-11-09: The IMAP CmRDT
Authors: Tim Jungnickel, Lennart Oldenburg and Matthias Loibl
2017-11-06: Hybrid Multi-Lane Spatial Logic
Author: Sven Linker
2017-10-26: The Kuratowski Closure-Complement Theorem
Authors: Peter Gammie and Gianpaolo Gioiosa
2017-10-19: Transition Systems and Automata
Author: Julian Brunner
2017-10-19: Büchi Complementation
Author: Julian Brunner
2017-10-17: Evaluate Winding Numbers through Cauchy Indices
Author: Wenda Li
2017-10-17: Count the Number of Complex Roots
Author: Wenda Li
2017-10-14: Homogeneous Linear Diophantine Equations
Authors: Florian Messner, Julian Parsert, Jonas Schöpf and Christian Sternagel
2017-10-12: The Hurwitz and Riemann ζ Functions
Author: Manuel Eberl
2017-10-12: Linear Recurrences
Author: Manuel Eberl
2017-10-12: Dirichlet Series
Author: Manuel Eberl
2017-09-21: Computer-assisted Reconstruction and Assessment of E. J. Lowe's Modal Ontological Argument
Authors: David Fuenmayor and Christoph Benzmüller
2017-09-17: Representation and Partial Automation of the Principia Logico-Metaphysica in Isabelle/HOL
Author: Daniel Kirchner
2017-09-06: Anselm's God in Isabelle/HOL
Author: Ben Blumson
2017-09-01: Microeconomics and the First Welfare Theorem
Authors: Julian Parsert and Cezary Kaliszyk
2017-08-20: Root-Balanced Tree
Author: Tobias Nipkow
2017-08-20: Orbit-Stabiliser Theorem with Application to Rotational Symmetries
Author: Jonas Rädle
2017-08-16: The LambdaMu-calculus
Authors: Cristina Matache, Victor B. F. Gomes and Dominic P. Mulligan
2017-07-31: Stewart's Theorem and Apollonius' Theorem
Author: Lukas Bulwahn
2017-07-28: Dynamic Architectures
Author: Diego Marmsoler
2017-07-21: Declarative Semantics for Functional Languages
Author: Jeremy Siek
2017-07-15: HOLCF-Prelude
Authors: Joachim Breitner, Brian Huffman, Neil Mitchell and Christian Sternagel
2017-07-13: Minkowski's Theorem
Author: Manuel Eberl
2017-07-09: Verified Metatheory and Type Inference for a Name-Carrying Simply-Typed Lambda Calculus
Author: Michael Rawson
2017-07-07: A framework for establishing Strong Eventual Consistency for Conflict-free Replicated Datatypes
Authors: Victor B. F. Gomes, Martin Kleppmann, Dominic P. Mulligan and Alastair R. Beresford
2017-07-06: Stone-Kleene Relation Algebras
Author: Walter Guttmann
2017-06-21: Propositional Proof Systems
Authors: Julius Michaelis and Tobias Nipkow
2017-06-13: Partial Semigroups and Convolution Algebras
Authors: Brijesh Dongol, Victor B. F. Gomes, Ian J. Hayes and Georg Struth
2017-06-06: Buffon's Needle Problem
Author: Manuel Eberl
2017-06-01: Formalizing Push-Relabel Algorithms
Authors: Peter Lammich and S. Reza Sefidgar
2017-06-01: Flow Networks and the Min-Cut-Max-Flow Theorem
Authors: Peter Lammich and S. Reza Sefidgar
2017-05-25: Optics
Authors: Simon Foster and Frank Zeyda
2017-05-24: Developing Security Protocols by Refinement
Authors: Christoph Sprenger and Ivano Somaini
2017-05-24: Dictionary Construction
Author: Lars Hupel
2017-05-08: The Floyd-Warshall Algorithm for Shortest Paths
Authors: Simon Wimmer and Peter Lammich
2017-05-05: Probabilistic while loop
Author: Andreas Lochbihler
2017-05-05: Effect polymorphism in higher-order logic
Author: Andreas Lochbihler
2017-05-05: Monad normalisation
Authors: Joshua Schneider, Manuel Eberl and Andreas Lochbihler
2017-05-05: Game-based cryptography in HOL
Authors: Andreas Lochbihler, S. Reza Sefidgar and Bhargav Bhatt
2017-05-05: CryptHOL
Author: Andreas Lochbihler
2017-05-04: Monoidal Categories
Author: Eugene W. Stark
2017-05-01: Types, Tableaus and Gödel’s God in Isabelle/HOL
Authors: David Fuenmayor and Christoph Benzmüller
2017-04-28: Local Lexing
Author: Steven Obua
2017-04-19: Constructor Functions
Author: Lars Hupel
2017-04-18: Lazifying case constants
Author: Lars Hupel
2017-04-06: Subresultants
Authors: Sebastiaan Joosten, René Thiemann and Akihisa Yamada
2017-04-04: Expected Shape of Random Binary Search Trees
Author: Manuel Eberl
2017-03-15: The number of comparisons in QuickSort
Author: Manuel Eberl
2017-03-15: Lower bound on comparison-based sorting algorithms
Author: Manuel Eberl
2017-03-10: The Euler–MacLaurin Formula
Author: Manuel Eberl
2017-02-28: The Group Law for Elliptic Curves
Author: Stefan Berghofer
2017-02-26: Menger's Theorem
Author: Christoph Dittmann
2017-02-13: Differential Dynamic Logic
Author: Brandon Bohrer
2017-02-10: Abstract Soundness
Authors: Jasmin Christian Blanchette, Andrei Popescu and Dmitriy Traytel
2017-02-07: Stone Relation Algebras
Author: Walter Guttmann
2017-01-31: Refining Authenticated Key Agreement with Strong Adversaries
Authors: Joseph Lallemand and Christoph Sprenger
2017-01-24: Bernoulli Numbers
Authors: Lukas Bulwahn and Manuel Eberl
2017-01-17: Minimal Static Single Assignment Form
Authors: Max Wagner and Denis Lohner
2017-01-17: Bertrand's postulate
Authors: Julian Biendarra and Manuel Eberl
2017-01-12: The Transcendence of e
Author: Manuel Eberl
2017-01-08: Formal Network Models and Their Application to Firewall Policies
Authors: Achim D. Brucker, Lukas Brügger and Burkhart Wolff
2017-01-03: Verification of a Diffie-Hellman Password-based Authentication Protocol by Extending the Inductive Method
Author: Pasquale Noce
2017-01-01: First-Order Logic According to Harrison
Authors: Alexander Birch Jensen, Anders Schlichtkrull and Jørgen Villadsen

 

2016
2016-12-30: Concurrent Refinement Algebra and Rely Quotients
Authors: Julian Fell, Ian J. Hayes and Andrius Velykis
2016-12-29: The Twelvefold Way
Author: Lukas Bulwahn
2016-12-20: Proof Strategy Language
Author: Yutaka Nagashima
2016-12-07: Paraconsistency
Authors: Anders Schlichtkrull and Jørgen Villadsen
2016-11-29: COMPLX: A Verification Framework for Concurrent Imperative Programs
Authors: Sidney Amani, June Andronick, Maksym Bortin, Corey Lewis, Christine Rizkallah and Joseph Tuong
2016-11-23: Abstract Interpretation of Annotated Commands
Author: Tobias Nipkow
2016-11-16: Separata: Isabelle tactics for Separation Algebra
Authors: Zhe Hou, David Sanan, Alwen Tiu, Rajeev Gore and Ranald Clouston
2016-11-12: Formalization of Nested Multisets, Hereditary Multisets, and Syntactic Ordinals
Authors: Jasmin Christian Blanchette, Mathias Fleury and Dmitriy Traytel
2016-11-12: Formalization of Knuth–Bendix Orders for Lambda-Free Higher-Order Terms
Authors: Heiko Becker, Jasmin Christian Blanchette, Uwe Waldmann and Daniel Wand
2016-11-10: Expressiveness of Deep Learning
Author: Alexander Bentkamp
2016-10-25: Modal Logics for Nominal Transition Systems
Authors: Tjark Weber, Lars-Henrik Eriksson, Joachim Parrow, Johannes Borgström and Ramunas Gutkovas
2016-10-24: Stable Matching
Author: Peter Gammie
2016-10-21: LOFT — Verified Migration of Linux Firewalls to SDN
Authors: Julius Michaelis and Cornelius Diekmann
2016-10-19: Source Coding Theorem
Authors: Quentin Hibon and Lawrence C. Paulson
2016-10-19: A formal model for the SPARCv8 ISA and a proof of non-interference for the LEON3 processor
Authors: Zhe Hou, David Sanan, Alwen Tiu and Yang Liu
2016-10-14: The Factorization Algorithm of Berlekamp and Zassenhaus
Authors: Jose Divasón, Sebastiaan Joosten, René Thiemann and Akihisa Yamada
2016-10-11: Intersecting Chords Theorem
Author: Lukas Bulwahn
2016-10-05: Lp spaces
Author: Sebastien Gouezel
2016-09-30: Fisher–Yates shuffle
Author: Manuel Eberl
2016-09-29: Allen's Interval Calculus
Author: Fadoua Ghourabi
2016-09-23: Formalization of Recursive Path Orders for Lambda-Free Higher-Order Terms
Authors: Jasmin Christian Blanchette, Uwe Waldmann and Daniel Wand
2016-09-09: Iptables Semantics
Authors: Cornelius Diekmann and Lars Hupel
2016-09-06: A Variant of the Superposition Calculus
Author: Nicolas Peltier
2016-09-06: Stone Algebras
Author: Walter Guttmann
2016-09-01: Stirling's formula
Author: Manuel Eberl
2016-08-31: Routing
Authors: Julius Michaelis and Cornelius Diekmann
2016-08-24: Simple Firewall
Authors: Cornelius Diekmann, Julius Michaelis and Maximilian Haslbeck
2016-08-18: Infeasible Paths Elimination by Symbolic Execution Techniques: Proof of Correctness and Preservation of Paths
Authors: Romain Aissat, Frederic Voisin and Burkhart Wolff
2016-08-12: Formalizing the Edmonds-Karp Algorithm
Authors: Peter Lammich and S. Reza Sefidgar
2016-08-08: The Imperative Refinement Framework
Author: Peter Lammich
2016-08-07: Ptolemy's Theorem
Author: Lukas Bulwahn
2016-07-17: Surprise Paradox
Author: Joachim Breitner
2016-07-14: Pairing Heap
Authors: Hauke Brinkop and Tobias Nipkow
2016-07-05: A Framework for Verifying Depth-First Search Algorithms
Authors: Peter Lammich and René Neumann
2016-07-01: Chamber Complexes, Coxeter Systems, and Buildings
Author: Jeremy Sylvestre
2016-06-30: The Z Property
Authors: Bertram Felgenhauer, Julian Nagele, Vincent van Oostrom and Christian Sternagel
2016-06-30: The Resolution Calculus for First-Order Logic
Author: Anders Schlichtkrull
2016-06-28: IP Addresses
Authors: Cornelius Diekmann, Julius Michaelis and Lars Hupel
2016-06-28: Compositional Security-Preserving Refinement for Concurrent Imperative Programs
Authors: Toby Murray, Robert Sison, Edward Pierzchalski and Christine Rizkallah
2016-06-26: Category Theory with Adjunctions and Limits
Author: Eugene W. Stark
2016-06-26: Cardinality of Multisets
Author: Lukas Bulwahn
2016-06-25: A Dependent Security Type System for Concurrent Imperative Programs
Authors: Toby Murray, Robert Sison, Edward Pierzchalski and Christine Rizkallah
2016-06-21: Catalan Numbers
Author: Manuel Eberl
2016-06-18: Program Construction and Verification Components Based on Kleene Algebra
Authors: Victor B. F. Gomes and Georg Struth
2016-06-13: Conservation of CSP Noninterference Security under Concurrent Composition
Author: Pasquale Noce
2016-06-09: Finite Machine Word Library
Authors: Joel Beeren, Matthew Fernandez, Xin Gao, Gerwin Klein, Rafal Kolanski, Japheth Lim, Corey Lewis, Daniel Matichuk and Thomas Sewell
2016-05-31: Tree Decomposition
Author: Christoph Dittmann
2016-05-24: POSIX Lexing with Derivatives of Regular Expressions
Authors: Fahad Ausaf, Roy Dyckhoff and Christian Urban
2016-05-24: Cardinality of Equivalence Relations
Author: Lukas Bulwahn
2016-05-20: Perron-Frobenius Theorem for Spectral Radius Analysis
Authors: Jose Divasón, Ondřej Kunčar, René Thiemann and Akihisa Yamada
2016-05-20: The meta theory of the Incredible Proof Machine
Authors: Joachim Breitner and Denis Lohner
2016-05-18: A Constructive Proof for FLP
Authors: Benjamin Bisping, Paul-David Brodmann, Tim Jungnickel, Christina Rickmann, Henning Seidler, Anke Stüber, Arno Wilhelm-Weidner, Kirstin Peters and Uwe Nestmann
2016-05-09: A Formal Proof of the Max-Flow Min-Cut Theorem for Countable Networks
Author: Andreas Lochbihler
2016-05-05: Randomised Social Choice Theory
Author: Manuel Eberl
2016-05-04: The Incompatibility of SD-Efficiency and SD-Strategy-Proofness
Author: Manuel Eberl
2016-05-04: Spivey's Generalized Recurrence for Bell Numbers
Author: Lukas Bulwahn
2016-05-02: Gröbner Bases Theory
Authors: Fabian Immler and Alexander Maletzky
2016-04-28: No Faster-Than-Light Observers
Authors: Mike Stannett and István Németi
2016-04-27: Algorithms for Reduced Ordered Binary Decision Diagrams
Authors: Julius Michaelis, Maximilian Haslbeck, Peter Lammich and Lars Hupel
2016-04-27: A formalisation of the Cocke-Younger-Kasami algorithm
Author: Maksym Bortin
2016-04-26: Conservation of CSP Noninterference Security under Sequential Composition
Author: Pasquale Noce
2016-04-12: Kleene Algebras with Domain
Authors: Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth and Tjark Weber
2016-03-11: Propositional Resolution and Prime Implicates Generation
Author: Nicolas Peltier
2016-03-08: Timed Automata
Author: Simon Wimmer
2016-03-08: The Cartan Fixed Point Theorems
Author: Lawrence C. Paulson
2016-03-01: Linear Temporal Logic
Author: Salomon Sickert
2016-02-17: Analysis of List Update Algorithms
Authors: Maximilian P.L. Haslbeck and Tobias Nipkow
2016-02-05: Verified Construction of Static Single Assignment Form
Authors: Sebastian Ullrich and Denis Lohner
2016-01-29: Polynomial Interpolation
Authors: René Thiemann and Akihisa Yamada
2016-01-29: Polynomial Factorization
Authors: René Thiemann and Akihisa Yamada
2016-01-20: Knot Theory
Author: T.V.H. Prathamesh
2016-01-18: Tensor Product of Matrices
Author: T.V.H. Prathamesh
2016-01-14: Cardinality of Number Partitions
Author: Lukas Bulwahn

 

2015
2015-12-28: Basic Geometric Properties of Triangles
Author: Manuel Eberl
2015-12-28: The Divergence of the Prime Harmonic Series
Author: Manuel Eberl
2015-12-28: Liouville numbers
Author: Manuel Eberl
2015-12-28: Descartes' Rule of Signs
Author: Manuel Eberl
2015-12-22: The Stern-Brocot Tree
Authors: Peter Gammie and Andreas Lochbihler
2015-12-22: Applicative Lifting
Authors: Andreas Lochbihler and Joshua Schneider
2015-12-22: Algebraic Numbers in Isabelle/HOL
Authors: René Thiemann, Akihisa Yamada and Sebastiaan Joosten
2015-12-12: Cardinality of Set Partitions
Author: Lukas Bulwahn
2015-12-02: Latin Square
Author: Alexander Bentkamp
2015-12-01: Ergodic Theory
Author: Sebastien Gouezel
2015-11-19: Euler's Partition Theorem
Author: Lukas Bulwahn
2015-11-18: The Tortoise and Hare Algorithm
Author: Peter Gammie
2015-11-11: Planarity Certificates
Author: Lars Noschinski
2015-11-02: Positional Determinacy of Parity Games
Author: Christoph Dittmann
2015-09-16: A Meta-Model for the Isabelle API
Authors: Frédéric Tuong and Burkhart Wolff
2015-09-04: Converting Linear Temporal Logic to Deterministic (Generalized) Rabin Automata
Author: Salomon Sickert
2015-08-21: Matrices, Jordan Normal Forms, and Spectral Radius Theory
Authors: René Thiemann and Akihisa Yamada
2015-08-20: Decreasing Diagrams II
Author: Bertram Felgenhauer
2015-08-18: The Inductive Unwinding Theorem for CSP Noninterference Security
Author: Pasquale Noce
2015-08-12: Representations of Finite Groups
Author: Jeremy Sylvestre
2015-08-10: Analysing and Comparing Encodability Criteria for Process Calculi
Authors: Kirstin Peters and Rob van Glabbeek
2015-07-21: Generating Cases from Labeled Subgoals
Author: Lars Noschinski
2015-07-14: Landau Symbols
Author: Manuel Eberl
2015-07-14: The Akra-Bazzi theorem and the Master theorem
Author: Manuel Eberl
2015-07-07: Hermite Normal Form
Authors: Jose Divasón and Jesús Aransay
2015-06-27: Derangements Formula
Author: Lukas Bulwahn
2015-06-11: The Ipurge Unwinding Theorem for CSP Noninterference Security
Author: Pasquale Noce
2015-06-11: The Generic Unwinding Theorem for CSP Noninterference Security
Author: Pasquale Noce
2015-06-11: Binary Multirelations
Authors: Hitoshi Furusawa and Georg Struth
2015-06-11: Reasoning about Lists via List Interleaving
Author: Pasquale Noce
2015-06-07: Parameterized Dynamic Tables
Author: Tobias Nipkow
2015-05-28: Derivatives of Logical Formulas
Author: Dmitriy Traytel
2015-05-27: A Zoo of Probabilistic Systems
Authors: Johannes Hölzl, Andreas Lochbihler and Dmitriy Traytel
2015-04-30: VCG - Combinatorial Vickrey-Clarke-Groves Auctions
Authors: Marco B. Caminati, Manfred Kerber, Christoph Lange and Colin Rowat
2015-04-15: Residuated Lattices
Authors: Victor B. F. Gomes and Georg Struth
2015-04-13: Concurrent IMP
Author: Peter Gammie
2015-04-13: Relaxing Safely: Verified On-the-Fly Garbage Collection for x86-TSO
Authors: Peter Gammie, Tony Hosking and Kai Engelhardt
2015-03-30: Trie
Authors: Andreas Lochbihler and Tobias Nipkow
2015-03-18: Consensus Refined
Authors: Ognjen Maric and Christoph Sprenger
2015-03-11: Deriving class instances for datatypes
Authors: Christian Sternagel and René Thiemann
2015-02-20: The Safety of Call Arity
Author: Joachim Breitner
2015-02-12: QR Decomposition
Authors: Jose Divasón and Jesús Aransay
2015-02-12: Echelon Form
Authors: Jose Divasón and Jesús Aransay
2015-02-05: Finite Automata in Hereditarily Finite Set Theory
Author: Lawrence C. Paulson
2015-01-28: Verification of the UpDown Scheme
Author: Johannes Hölzl

 

2014
2014-11-28: The Unified Policy Framework (UPF)
Authors: Achim D. Brucker, Lukas Brügger and Burkhart Wolff
2014-10-23: Loop freedom of the (untimed) AODV routing protocol
Authors: Timothy Bourke and Peter Höfner
2014-10-13: Lifting Definition Option
Author: René Thiemann
2014-10-10: Stream Fusion in HOL with Code Generation
Authors: Andreas Lochbihler and Alexandra Maximova
2014-10-09: A Verified Compiler for Probability Density Functions
Authors: Manuel Eberl, Johannes Hölzl and Tobias Nipkow
2014-10-08: Formalization of Refinement Calculus for Reactive Systems
Author: Viorel Preoteasa
2014-10-03: XML
Authors: Christian Sternagel and René Thiemann
2014-10-03: Certification Monads
Authors: Christian Sternagel and René Thiemann
2014-09-25: Imperative Insertion Sort
Author: Christian Sternagel
2014-09-19: The Sturm-Tarski Theorem
Author: Wenda Li
2014-09-15: The Cayley-Hamilton Theorem
Authors: Stephan Adelsberger, Stefan Hetzl and Florian Pollak
2014-09-09: The Jordan-Hölder Theorem
Author: Jakob von Raumer
2014-09-04: Priority Queues Based on Braun Trees
Author: Tobias Nipkow
2014-09-03: Gauss-Jordan Algorithm and Its Applications
Authors: Jose Divasón and Jesús Aransay
2014-08-29: Vector Spaces
Author: Holden Lee
2014-08-29: Real-Valued Special Functions: Upper and Lower Bounds
Author: Lawrence C. Paulson
2014-08-13: Skew Heap
Author: Tobias Nipkow
2014-08-12: Splay Tree
Author: Tobias Nipkow
2014-07-29: Haskell's Show Class in Isabelle/HOL
Authors: Christian Sternagel and René Thiemann
2014-07-18: Formal Specification of a Generic Separation Kernel
Authors: Freek Verbeek, Sergey Tverdyshev, Oto Havle, Holger Blasum, Bruno Langenstein, Werner Stephan, Yakoub Nemouchi, Abderrahmane Feliachi, Burkhart Wolff and Julien Schmaltz
2014-07-13: pGCL for Isabelle
Author: David Cock
2014-07-07: Amortized Complexity Verified
Author: Tobias Nipkow
2014-07-04: Network Security Policy Verification
Author: Cornelius Diekmann
2014-07-03: Pop-Refinement
Author: Alessandro Coglio
2014-06-12: Decision Procedures for MSO on Words Based on Derivatives of Regular Expressions
Authors: Dmitriy Traytel and Tobias Nipkow
2014-06-08: Boolean Expression Checkers
Author: Tobias Nipkow
2014-05-28: Promela Formalization
Author: René Neumann
2014-05-28: Converting Linear-Time Temporal Logic to Generalized Büchi Automata
Authors: Alexander Schimpf and Peter Lammich
2014-05-28: Verified Efficient Implementation of Gabow's Strongly Connected Components Algorithm
Author: Peter Lammich
2014-05-28: A Fully Verified Executable LTL Model Checker
Authors: Javier Esparza, Peter Lammich, René Neumann, Tobias Nipkow, Alexander Schimpf and Jan-Georg Smaus
2014-05-28: The CAVA Automata Library
Author: Peter Lammich
2014-05-23: Transitive closure according to Roy-Floyd-Warshall
Author: Makarius Wenzel
2014-05-23: Noninterference Security in Communicating Sequential Processes
Author: Pasquale Noce
2014-05-21: Regular Algebras
Authors: Simon Foster and Georg Struth
2014-04-28: Formalisation and Analysis of Component Dependencies
Author: Maria Spichkova
2014-04-23: A Formalization of Declassification with WHAT-and-WHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel and Jens Sauer
2014-04-23: A Formalization of Strong Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel and Jens Sauer
2014-04-23: A Formalization of Assumptions and Guarantees for Compositional Noninterference
Authors: Sylvia Grewe, Heiko Mantel and Daniel Schoepe
2014-04-22: Bounded-Deducibility Security
Authors: Andrei Popescu and Peter Lammich
2014-04-16: A shallow embedding of HyperCTL*
Authors: Markus N. Rabe, Peter Lammich and Andrei Popescu
2014-04-16: Abstract Completeness
Authors: Jasmin Christian Blanchette, Andrei Popescu and Dmitriy Traytel
2014-04-13: Discrete Summation
Author: Florian Haftmann
2014-04-03: Syntax and semantics of a GPU kernel programming language
Author: John Wickerson
2014-03-11: Probabilistic Noninterference
Authors: Andrei Popescu and Johannes Hölzl
2014-03-08: Mechanization of the Algebra for Wireless Networks (AWN)
Author: Timothy Bourke
2014-02-18: Mutually Recursive Partial Functions
Author: René Thiemann
2014-02-13: Properties of Random Graphs -- Subgraph Containment
Author: Lars Hupel
2014-02-11: Verification of Selection and Heap Sort Using Locales
Author: Danijela Petrovic
2014-02-07: Affine Arithmetic
Author: Fabian Immler
2014-02-06: Implementing field extensions of the form Q[sqrt(b)]
Author: René Thiemann
2014-01-30: Unified Decision Procedures for Regular Expression Equivalence
Authors: Tobias Nipkow and Dmitriy Traytel
2014-01-28: Secondary Sylow Theorems
Author: Jakob von Raumer
2014-01-25: Relation Algebra
Authors: Alasdair Armstrong, Simon Foster, Georg Struth and Tjark Weber
2014-01-23: Kleene Algebra with Tests and Demonic Refinement Algebras
Authors: Alasdair Armstrong, Victor B. F. Gomes and Georg Struth
2014-01-16: Featherweight OCL: A Proposal for a Machine-Checked Formal Semantics for OCL 2.5
Authors: Achim D. Brucker, Frédéric Tuong and Burkhart Wolff
2014-01-11: Sturm's Theorem
Author: Manuel Eberl
2014-01-11: Compositional Properties of Crypto-Based Components
Author: Maria Spichkova

 

2013
2013-12-01: A General Method for the Proof of Theorems on Tail-recursive Functions
Author: Pasquale Noce
2013-11-17: Gödel's Incompleteness Theorems
Author: Lawrence C. Paulson
2013-11-17: The Hereditarily Finite Sets
Author: Lawrence C. Paulson
2013-11-15: A Codatatype of Formal Languages
Author: Dmitriy Traytel
2013-11-14: Stream Processing Components: Isabelle/HOL Formalisation and Case Studies
Author: Maria Spichkova
2013-11-12: Gödel's God in Isabelle/HOL
Authors: Christoph Benzmüller and Bruno Woltzenlogel Paleo
2013-11-01: Decreasing Diagrams
Author: Harald Zankl
2013-10-02: Automatic Data Refinement
Author: Peter Lammich
2013-09-17: Native Word
Author: Andreas Lochbihler
2013-07-27: A Formal Model of IEEE Floating Point Arithmetic
Author: Lei Yu
2013-07-22: Pratt's Primality Certificates
Authors: Simon Wimmer and Lars Noschinski
2013-07-22: Lehmer's Theorem
Authors: Simon Wimmer and Lars Noschinski
2013-07-19: The Königsberg Bridge Problem and the Friendship Theorem
Author: Wenda Li
2013-06-27: Sound and Complete Sort Encodings for First-Order Logic
Authors: Jasmin Christian Blanchette and Andrei Popescu
2013-05-22: An Axiomatic Characterization of the Single-Source Shortest Path Problem
Author: Christine Rizkallah
2013-04-28: Graph Theory
Author: Lars Noschinski
2013-04-15: Light-weight Containers
Author: Andreas Lochbihler
2013-02-21: Nominal 2
Authors: Christian Urban, Stefan Berghofer and Cezary Kaliszyk
2013-01-31: The Correctness of Launchbury's Natural Semantics for Lazy Evaluation
Author: Joachim Breitner
2013-01-19: Ribbon Proofs
Author: John Wickerson
2013-01-16: Rank-Nullity Theorem in Linear Algebra
Authors: Jose Divasón and Jesús Aransay
2013-01-15: Kleene Algebra
Authors: Alasdair Armstrong, Georg Struth and Tjark Weber
2013-01-03: Computing N-th Roots using the Babylonian Method
Author: René Thiemann

 

2012
2012-11-14: A Separation Logic Framework for Imperative HOL
Authors: Peter Lammich and Rene Meis
2012-11-02: Open Induction
Authors: Mizuhito Ogawa and Christian Sternagel
2012-10-30: The independence of Tarski's Euclidean axiom
Author: T. J. M. Makarios
2012-10-27: Bondy's Theorem
Authors: Jeremy Avigad and Stefan Hetzl
2012-09-10: Possibilistic Noninterference
Authors: Andrei Popescu and Johannes Hölzl
2012-08-07: Generating linear orders for datatypes
Author: René Thiemann
2012-08-05: Proving the Impossibility of Trisecting an Angle and Doubling the Cube
Authors: Ralph Romanos and Lawrence C. Paulson
2012-07-27: Verifying Fault-Tolerant Distributed Algorithms in the Heard-Of Model
Authors: Henri Debrat and Stephan Merz
2012-07-01: Logical Relations for PCF
Author: Peter Gammie
2012-06-26: Type Constructor Classes and Monad Transformers
Author: Brian Huffman
2012-05-29: Psi-calculi in Isabelle
Author: Jesper Bengtson
2012-05-29: The pi-calculus in nominal logic
Author: Jesper Bengtson
2012-05-29: CCS in nominal logic
Author: Jesper Bengtson
2012-05-27: Isabelle/Circus
Authors: Abderrahmane Feliachi, Burkhart Wolff and Marie-Claude Gaudel
2012-05-11: Separation Algebra
Authors: Gerwin Klein, Rafal Kolanski and Andrew Boyton
2012-05-07: Stuttering Equivalence
Author: Stephan Merz
2012-05-02: Inductive Study of Confidentiality
Author: Giampaolo Bella
2012-04-26: Ordinary Differential Equations
Authors: Fabian Immler and Johannes Hölzl
2012-04-13: Well-Quasi-Orders
Author: Christian Sternagel
2012-03-01: Abortable Linearizable Modules
Authors: Rachid Guerraoui, Viktor Kuncak and Giuliano Losa
2012-02-29: Executable Transitive Closures
Author: René Thiemann
2012-02-06: A Probabilistic Proof of the Girth-Chromatic Number Theorem
Author: Lars Noschinski
2012-01-30: Refinement for Monadic Programs
Author: Peter Lammich
2012-01-30: Dijkstra's Shortest Path Algorithm
Authors: Benedikt Nordhoff and Peter Lammich
2012-01-03: Markov Models
Authors: Johannes Hölzl and Tobias Nipkow

 

2011
2011-11-19: A Definitional Encoding of TLA* in Isabelle/HOL
Authors: Gudmund Grov and Stephan Merz
2011-11-09: Efficient Mergesort
Author: Christian Sternagel
2011-09-22: Pseudo Hoops
Authors: George Georgescu, Laurentiu Leustean and Viorel Preoteasa
2011-09-22: Algebra of Monotonic Boolean Transformers
Author: Viorel Preoteasa
2011-09-22: Lattice Properties
Author: Viorel Preoteasa
2011-08-26: The Myhill-Nerode Theorem Based on Regular Expressions
Authors: Chunhan Wu, Xingyuan Zhang and Christian Urban
2011-08-19: Gauss-Jordan Elimination for Matrices Represented as Functions
Author: Tobias Nipkow
2011-07-21: Maximum Cardinality Matching
Author: Christine Rizkallah
2011-05-17: Knowledge-based programs
Author: Peter Gammie
2011-04-01: The General Triangle Is Unique
Author: Joachim Breitner
2011-03-14: Executable Transitive Closures of Finite Relations
Authors: Christian Sternagel and René Thiemann
2011-02-23: Interval Temporal Logic on Natural Numbers
Author: David Trachtenherz
2011-02-23: Infinite Lists
Author: David Trachtenherz
2011-02-23: AutoFocus Stream Processing for Single-Clocking and Multi-Clocking Semantics
Author: David Trachtenherz
2011-02-07: Lightweight Java
Authors: Rok Strniša and Matthew Parkinson
2011-01-10: RIPEMD-160
Author: Fabian Immler
2011-01-08: Lower Semicontinuous Functions
Author: Bogdan Grechuk

 

2010
2010-12-17: Hall's Marriage Theorem
Authors: Dongchen Jiang and Tobias Nipkow
2010-11-16: Shivers' Control Flow Analysis
Author: Joachim Breitner
2010-10-28: Finger Trees
Authors: Benedikt Nordhoff, Stefan Körner and Peter Lammich
2010-10-28: Functional Binomial Queues
Author: René Neumann
2010-10-28: Binomial Heaps and Skew Binomial Heaps
Authors: Rene Meis, Finn Nielsen and Peter Lammich
2010-08-29: Strong Normalization of Moggis's Computational Metalanguage
Author: Christian Doczkal
2010-08-10: Executable Multivariate Polynomials
Authors: Christian Sternagel, René Thiemann, Alexander Maletzky, Fabian Immler, Florian Haftmann, Andreas Lochbihler and Alexander Bentkamp
2010-08-08: Formalizing Statecharts using Hierarchical Automata
Authors: Steffen Helke and Florian Kammüller
2010-06-24: Free Groups
Author: Joachim Breitner
2010-06-20: Category Theory
Author: Alexander Katovsky
2010-06-17: Executable Matrix Operations on Matrices of Arbitrary Dimensions
Authors: Christian Sternagel and René Thiemann
2010-06-14: Abstract Rewriting
Authors: Christian Sternagel and René Thiemann
2010-05-28: Verification of the Deutsch-Schorr-Waite Graph Marking Algorithm using Data Refinement
Authors: Viorel Preoteasa and Ralph-Johan Back
2010-05-28: Semantics and Data Refinement of Invariant Based Programs
Authors: Viorel Preoteasa and Ralph-Johan Back
2010-05-22: A Complete Proof of the Robbins Conjecture
Author: Matthew Wampler-Doty
2010-05-12: Regular Sets and Expressions
Authors: Alexander Krauss and Tobias Nipkow
2010-04-30: Locally Nameless Sigma Calculus
Authors: Ludovic Henrio, Florian Kammüller, Bianca Lutz and Henry Sudhof
2010-03-29: Free Boolean Algebra
Author: Brian Huffman
2010-03-23: Inter-Procedural Information Flow Noninterference via Slicing
Author: Daniel Wasserrab
2010-03-23: Information Flow Noninterference via Slicing
Author: Daniel Wasserrab
2010-02-20: List Index
Author: Tobias Nipkow
2010-02-12: Coinductive
Author: Andreas Lochbihler

 

2009
2009-12-09: A Fast SAT Solver for Isabelle in Standard ML
Author: Armin Heller
2009-12-03: Formalizing the Logic-Automaton Connection
Authors: Stefan Berghofer and Markus Reiter
2009-11-25: Tree Automata
Author: Peter Lammich
2009-11-25: Collections Framework
Author: Peter Lammich
2009-11-22: Perfect Number Theorem
Author: Mark Ijbema
2009-11-13: Backing up Slicing: Verifying the Interprocedural Two-Phase Horwitz-Reps-Binkley Slicer
Author: Daniel Wasserrab
2009-10-30: The Worker/Wrapper Transformation
Author: Peter Gammie
2009-09-01: Ordinals and Cardinals
Author: Andrei Popescu
2009-08-28: Invertibility in Sequent Calculi
Author: Peter Chapman
2009-08-04: An Example of a Cofinitary Group in Isabelle/HOL
Author: Bart Kastermans
2009-05-06: Code Generation for Functions as Data
Author: Andreas Lochbihler
2009-04-29: Stream Fusion
Author: Brian Huffman

 

2008
2008-12-12: A Bytecode Logic for JML and Types
Authors: Lennart Beringer and Martin Hofmann
2008-11-10: Secure information flow and program logics
Authors: Lennart Beringer and Martin Hofmann
2008-11-09: Some classical results in Social Choice Theory
Author: Peter Gammie
2008-11-07: Fun With Tilings
Authors: Tobias Nipkow and Lawrence C. Paulson
2008-10-15: The Textbook Proof of Huffman's Algorithm
Author: Jasmin Christian Blanchette
2008-09-16: Towards Certified Slicing
Author: Daniel Wasserrab
2008-09-02: A Correctness Proof for the Volpano/Smith Security Typing System
Authors: Gregor Snelting and Daniel Wasserrab
2008-09-01: Arrow and Gibbard-Satterthwaite
Author: Tobias Nipkow
2008-08-26: Fun With Functions
Author: Tobias Nipkow
2008-07-23: Formal Verification of Modern SAT Solvers
Author: Filip Marić
2008-04-05: Recursion Theory I
Author: Michael Nedzelsky
2008-02-29: A Sequential Imperative Programming Language Syntax, Semantics, Hoare Logics and Verification Environment
Author: Norbert Schirmer
2008-02-29: BDD Normalisation
Authors: Veronika Ortner and Norbert Schirmer
2008-02-18: Normalization by Evaluation
Authors: Klaus Aehlig and Tobias Nipkow
2008-01-11: Quantifier Elimination for Linear Arithmetic
Author: Tobias Nipkow

 

2007
2007-12-14: Formalization of Conflict Analysis of Programs with Procedures, Thread Creation, and Monitors
Authors: Peter Lammich and Markus Müller-Olm
2007-12-03: Jinja with Threads
Author: Andreas Lochbihler
2007-11-06: Much Ado About Two
Author: Sascha Böhme
2007-08-12: Sums of Two and Four Squares
Author: Roelof Oosterhuis
2007-08-12: Fermat's Last Theorem for Exponents 3 and 4 and the Parametrisation of Pythagorean Triples
Author: Roelof Oosterhuis
2007-08-08: Fundamental Properties of Valuation Theory and Hensel's Lemma
Author: Hidetsune Kobayashi
2007-08-02: POPLmark Challenge Via de Bruijn Indices
Author: Stefan Berghofer
2007-08-02: First-Order Logic According to Fitting
Author: Stefan Berghofer

 

2006
2006-09-09: Hotel Key Card System
Author: Tobias Nipkow
2006-08-08: Abstract Hoare Logics
Author: Tobias Nipkow
2006-05-22: Flyspeck I: Tame Graphs
Authors: Gertrud Bauer and Tobias Nipkow
2006-05-15: CoreC++
Author: Daniel Wasserrab
2006-03-31: A Theory of Featherweight Java in Isabelle/HOL
Authors: J. Nathan Foster and Dimitrios Vytiniotis
2006-03-15: Instances of Schneider's generalized protocol of clock synchronization
Author: Damián Barsotti
2006-03-14: Cauchy's Mean Theorem and the Cauchy-Schwarz Inequality
Author: Benjamin Porter

 

2005
2005-11-11: Countable Ordinals
Author: Brian Huffman
2005-10-12: Fast Fourier Transform
Author: Clemens Ballarin
2005-06-24: Formalization of a Generalized Protocol for Clock Synchronization
Author: Alwen Tiu
2005-06-22: Proving the Correctness of Disk Paxos
Authors: Mauro Jaskelioff and Stephan Merz
2005-06-20: Jive Data and Store Model
Authors: Nicole Rauch and Norbert Schirmer
2005-06-01: Jinja is not Java
Authors: Gerwin Klein and Tobias Nipkow
2005-05-02: SHA1, RSA, PSS and more
Authors: Christina Lindenberg and Kai Wirt
2005-04-21: Category Theory to Yoneda's Lemma
Author: Greg O'Keefe

 

2004
2004-12-09: File Refinement
Authors: Karen Zee and Viktor Kuncak
2004-11-19: Integration theory and random variables
Author: Stefan Richter
2004-09-28: A Mechanically Verified, Efficient, Sound and Complete Theorem Prover For First Order Logic
Author: Tom Ridge
2004-09-20: Ramsey's theorem, infinitary version
Author: Tom Ridge
2004-09-20: Completeness theorem
Authors: James Margetson and Tom Ridge
2004-07-09: Compiling Exceptions Correctly
Author: Tobias Nipkow
2004-06-24: Depth First Search
Authors: Toshiaki Nishihara and Yasuhiko Minamide
2004-05-18: Groups, Rings and Modules
Authors: Hidetsune Kobayashi, L. Chen and H. Murao
2004-04-26: Topology
Author: Stefan Friedrich
2004-04-26: Lazy Lists II
Author: Stefan Friedrich
2004-04-05: Binary Search Trees
Author: Viktor Kuncak
2004-03-30: Functional Automata
Author: Tobias Nipkow
2004-03-19: Mini ML
Authors: Wolfgang Naraschewski and Tobias Nipkow
2004-03-19: AVL Trees
Authors: Tobias Nipkow and Cornelia Pusch
\ No newline at end of file diff --git a/web/rss.xml b/web/rss.xml --- a/web/rss.xml +++ b/web/rss.xml @@ -1,589 +1,600 @@ Archive of Formal Proofs https://www.isa-afp.org The Archive of Formal Proofs is a collection of proof libraries, examples, and larger scientific developments, mechanically checked in the theorem prover Isabelle. - 25 Aug 2020 00:00:00 +0000 + 26 Aug 2020 00:00:00 +0000 + + Relational Disjoint-Set Forests + https://www.isa-afp.org/entries/Relational_Disjoint_Set_Forests.html + https://www.isa-afp.org/entries/Relational_Disjoint_Set_Forests.html + Walter Guttmann + 26 Aug 2020 00:00:00 +0000 + +We give a simple relation-algebraic semantics of read and write +operations on associative arrays. The array operations seamlessly +integrate with assignments in the Hoare-logic library. Using relation +algebras and Kleene algebras we verify the correctness of an +array-based implementation of disjoint-set forests with a naive union +operation and a find operation with path compression. + Extensions to the Comprehensive Framework for Saturation Theorem Proving https://www.isa-afp.org/entries/Saturation_Framework_Extensions.html https://www.isa-afp.org/entries/Saturation_Framework_Extensions.html Jasmin Blanchette, Sophie Tourret 25 Aug 2020 00:00:00 +0000 This Isabelle/HOL formalization extends the AFP entry <em>Saturation_Framework</em> with the following contributions: <ul> <li>an application of the framework to prove Bachmair and Ganzinger's resolution prover RP refutationally complete, which was formalized in a more ad hoc fashion by Schlichtkrull et al. in the AFP entry <em>Ordered_Resultion_Prover</em>;</li> <li>generalizations of various basic concepts formalized by Schlichtkrull et al., which were needed to verify RP and could be useful to formalize other calculi, such as superposition;</li> <li>alternative proofs of fairness (and hence saturation and ultimately refutational completeness) for the given clause procedures GC and LGC, based on invariance.</li> </ul> + Amicable Numbers + https://www.isa-afp.org/entries/Amicable_Numbers.html + https://www.isa-afp.org/entries/Amicable_Numbers.html + Angeliki Koutsoukou-Argyraki + 04 Aug 2020 00:00:00 +0000 + +This is a formalisation of Amicable Numbers, involving some relevant +material including Euler's sigma function, some relevant +definitions, results and examples as well as rules such as +Th&#257;bit ibn Qurra's Rule, Euler's Rule, te +Riele's Rule and Borho's Rule with breeders. + + + Ordinal Partitions + https://www.isa-afp.org/entries/Ordinal_Partitions.html + https://www.isa-afp.org/entries/Ordinal_Partitions.html + Lawrence C. Paulson + 03 Aug 2020 00:00:00 +0000 + +The theory of partition relations concerns generalisations of +Ramsey's theorem. For any ordinal $\alpha$, write $\alpha \to +(\alpha, m)^2$ if for each function $f$ from unordered pairs of +elements of $\alpha$ into $\{0,1\}$, either there is a subset +$X\subseteq \alpha$ order-isomorphic to $\alpha$ such that +$f\{x,y\}=0$ for all $\{x,y\}\subseteq X$, or there is an $m$ element +set $Y\subseteq \alpha$ such that $f\{x,y\}=1$ for all +$\{x,y\}\subseteq Y$. (In both cases, with $\{x,y\}$ we require +$x\not=y$.) In particular, the infinite Ramsey theorem can be written +in this notation as $\omega \to (\omega, \omega)^2$, or if we +restrict $m$ to the positive integers as above, then $\omega \to +(\omega, m)^2$ for all $m$. This entry formalises Larson's proof +of $\omega^\omega \to (\omega^\omega, m)^2$ along with a similar proof +of a result due to Specker: $\omega^2 \to (\omega^2, m)^2$. Also +proved is a necessary result by Erdős and Milner: +$\omega^{1+\alpha\cdot n} \to (\omega^{1+\alpha}, 2^n)^2$. + + + A Formal Proof of The Chandy--Lamport Distributed Snapshot Algorithm + https://www.isa-afp.org/entries/Chandy_Lamport.html + https://www.isa-afp.org/entries/Chandy_Lamport.html + Ben Fiedler, Dmitriy Traytel + 21 Jul 2020 00:00:00 +0000 + +We provide a suitable distributed system model and implementation of the +Chandy--Lamport distributed snapshot algorithm [ACM Transactions on +Computer Systems, 3, 63-75, 1985]. Our main result is a formal +termination and correctness proof of the Chandy--Lamport algorithm and +its use in stable property detection. + + + Relational Characterisations of Paths + https://www.isa-afp.org/entries/Relational_Paths.html + https://www.isa-afp.org/entries/Relational_Paths.html + Walter Guttmann, Peter Höfner + 13 Jul 2020 00:00:00 +0000 + +Binary relations are one of the standard ways to encode, characterise +and reason about graphs. Relation algebras provide equational axioms +for a large fragment of the calculus of binary relations. Although +relations are standard tools in many areas of mathematics and +computing, researchers usually fall back to point-wise reasoning when +it comes to arguments about paths in a graph. We present a purely +algebraic way to specify different kinds of paths in Kleene relation +algebras, which are relation algebras equipped with an operation for +reflexive transitive closure. We study the relationship between paths +with a designated root vertex and paths without such a vertex. Since +we stay in first-order logic this development helps with mechanising +proofs. To demonstrate the applicability of the algebraic framework we +verify the correctness of three basic graph algorithms. + + A Formally Verified Checker of the Safe Distance Traffic Rules for Autonomous Vehicles https://www.isa-afp.org/entries/Safe_Distance.html https://www.isa-afp.org/entries/Safe_Distance.html Albert Rizaldi, Fabian Immler 01 Jun 2020 00:00:00 +0000 The Vienna Convention on Road Traffic defines the safe distance traffic rules informally. This could make autonomous vehicle liable for safe-distance-related accidents because there is no clear definition of how large a safe distance is. We provide a formally proven prescriptive definition of a safe distance, and checkers which can decide whether an autonomous vehicle is obeying the safe distance rule. Not only does our work apply to the domain of law, but it also serves as a specification for autonomous vehicle manufacturers and for online verification of path planners. A verified algorithm for computing the Smith normal form of a matrix https://www.isa-afp.org/entries/Smith_Normal_Form.html https://www.isa-afp.org/entries/Smith_Normal_Form.html Jose Divasón 23 May 2020 00:00:00 +0000 This work presents a formal proof in Isabelle/HOL of an algorithm to transform a matrix into its Smith normal form, a canonical matrix form, in a general setting: the algorithm is parameterized by operations to prove its existence over elementary divisor rings, while execution is guaranteed over Euclidean domains. We also provide a formal proof on some results about the generality of this algorithm as well as the uniqueness of the Smith normal form. Since Isabelle/HOL does not feature dependent types, the development is carried out switching conveniently between two different existing libraries: the Hermite normal form (based on HOL Analysis) and the Jordan normal form AFP entries. This permits to reuse results from both developments and it is done by means of the lifting and transfer package together with the use of local type definitions. The Nash-Williams Partition Theorem https://www.isa-afp.org/entries/Nash_Williams.html https://www.isa-afp.org/entries/Nash_Williams.html Lawrence C. Paulson 16 May 2020 00:00:00 +0000 In 1965, Nash-Williams discovered a generalisation of the infinite form of Ramsey's theorem. Where the latter concerns infinite sets of n-element sets for some fixed n, the Nash-Williams theorem concerns infinite sets of finite sets (or lists) subject to a “no initial segment” condition. The present formalisation follows a monograph on Ramsey Spaces by Todorčević. A Formalization of Knuth–Bendix Orders https://www.isa-afp.org/entries/Knuth_Bendix_Order.html https://www.isa-afp.org/entries/Knuth_Bendix_Order.html Christian Sternagel, René Thiemann 13 May 2020 00:00:00 +0000 We define a generalized version of Knuth&ndash;Bendix orders, including subterm coefficient functions. For these orders we formalize several properties such as strong normalization, the subterm property, closure properties under substitutions and contexts, as well as ground totality. Irrationality Criteria for Series by Erdős and Straus https://www.isa-afp.org/entries/Irrational_Series_Erdos_Straus.html https://www.isa-afp.org/entries/Irrational_Series_Erdos_Straus.html Angeliki Koutsoukou-Argyraki, Wenda Li 12 May 2020 00:00:00 +0000 We formalise certain irrationality criteria for infinite series of the form: \[\sum_{n=1}^\infty \frac{b_n}{\prod_{i=1}^n a_i} \] where $\{b_n\}$ is a sequence of integers and $\{a_n\}$ a sequence of positive integers with $a_n >1$ for all large n. The results are due to P. Erdős and E. G. Straus <a href="https://projecteuclid.org/euclid.pjm/1102911140">[1]</a>. In particular, we formalise Theorem 2.1, Corollary 2.10 and Theorem 3.1. The latter is an application of Theorem 2.1 involving the prime numbers. Recursion Theorem in ZF https://www.isa-afp.org/entries/Recursion-Addition.html https://www.isa-afp.org/entries/Recursion-Addition.html Georgy Dunaev 11 May 2020 00:00:00 +0000 This document contains a proof of the recursion theorem. This is a mechanization of the proof of the recursion theorem from the text <i>Introduction to Set Theory</i>, by Karel Hrbacek and Thomas Jech. This implementation may be used as the basis for a model of Peano arithmetic in ZF. While recursion and the natural numbers are already available in Isabelle/ZF, this clean development is much easier to follow. An Efficient Normalisation Procedure for Linear Temporal Logic: Isabelle/HOL Formalisation https://www.isa-afp.org/entries/LTL_Normal_Form.html https://www.isa-afp.org/entries/LTL_Normal_Form.html Salomon Sickert 08 May 2020 00:00:00 +0000 In the mid 80s, Lichtenstein, Pnueli, and Zuck proved a classical theorem stating that every formula of Past LTL (the extension of LTL with past operators) is equivalent to a formula of the form $\bigwedge_{i=1}^n \mathbf{G}\mathbf{F} \varphi_i \vee \mathbf{F}\mathbf{G} \psi_i$, where $\varphi_i$ and $\psi_i$ contain only past operators. Some years later, Chang, Manna, and Pnueli built on this result to derive a similar normal form for LTL. Both normalisation procedures have a non-elementary worst-case blow-up, and follow an involved path from formulas to counter-free automata to star-free regular expressions and back to formulas. We improve on both points. We present an executable formalisation of a direct and purely syntactic normalisation procedure for LTL yielding a normal form, comparable to the one by Chang, Manna, and Pnueli, that has only a single exponential blow-up. Formalization of Forcing in Isabelle/ZF https://www.isa-afp.org/entries/Forcing.html https://www.isa-afp.org/entries/Forcing.html Emmanuel Gunther, Miguel Pagano, Pedro Sánchez Terraf 06 May 2020 00:00:00 +0000 We formalize the theory of forcing in the set theory framework of Isabelle/ZF. Under the assumption of the existence of a countable transitive model of ZFC, we construct a proper generic extension and show that the latter also satisfies ZFC. Banach-Steinhaus Theorem https://www.isa-afp.org/entries/Banach_Steinhaus.html https://www.isa-afp.org/entries/Banach_Steinhaus.html Dominique Unruh, Jose Manuel Rodriguez Caballero 02 May 2020 00:00:00 +0000 We formalize in Isabelle/HOL a result due to S. Banach and H. Steinhaus known as the Banach-Steinhaus theorem or Uniform boundedness principle: a pointwise-bounded family of continuous linear operators from a Banach space to a normed space is uniformly bounded. Our approach is an adaptation to Isabelle/HOL of a proof due to A. Sokal. Attack Trees in Isabelle for GDPR compliance of IoT healthcare systems https://www.isa-afp.org/entries/Attack_Trees.html https://www.isa-afp.org/entries/Attack_Trees.html Florian Kammueller 27 Apr 2020 00:00:00 +0000 In this article, we present a proof theory for Attack Trees. Attack Trees are a well established and useful model for the construction of attacks on systems since they allow a stepwise exploration of high level attacks in application scenarios. Using the expressiveness of Higher Order Logic in Isabelle, we develop a generic theory of Attack Trees with a state-based semantics based on Kripke structures and CTL. The resulting framework allows mechanically supported logic analysis of the meta-theory of the proof calculus of Attack Trees and at the same time the developed proof theory enables application to case studies. A central correctness and completeness result proved in Isabelle establishes a connection between the notion of Attack Tree validity and CTL. The application is illustrated on the example of a healthcare IoT system and GDPR compliance verification. Power Sum Polynomials https://www.isa-afp.org/entries/Power_Sum_Polynomials.html https://www.isa-afp.org/entries/Power_Sum_Polynomials.html Manuel Eberl 24 Apr 2020 00:00:00 +0000 <p>This article provides a formalisation of the symmetric multivariate polynomials known as <em>power sum polynomials</em>. These are of the form p<sub>n</sub>(<em>X</em><sub>1</sub>,&hellip;, <em>X</em><sub><em>k</em></sub>) = <em>X</em><sub>1</sub><sup>n</sup> + &hellip; + X<sub><em>k</em></sub><sup>n</sup>. A formal proof of the Girard–Newton Theorem is also given. This theorem relates the power sum polynomials to the elementary symmetric polynomials s<sub><em>k</em></sub> in the form of a recurrence relation (-1)<sup><em>k</em></sup> <em>k</em> s<sub><em>k</em></sub> = &sum;<sub>i&isinv;[0,<em>k</em>)</sub> (-1)<sup>i</sup> s<sub>i</sub> p<sub><em>k</em>-<em>i</em></sub>&thinsp;.</p> <p>As an application, this is then used to solve a generalised form of a puzzle given as an exercise in Dummit and Foote's <em>Abstract Algebra</em>: For <em>k</em> complex unknowns <em>x</em><sub>1</sub>, &hellip;, <em>x</em><sub><em>k</em></sub>, define p<sub><em>j</em></sub> := <em>x</em><sub>1</sub><sup><em>j</em></sup> + &hellip; + <em>x</em><sub><em>k</em></sub><sup><em>j</em></sup>. Then for each vector <em>a</em> &isinv; &#x2102;<sup><em>k</em></sup>, show that there is exactly one solution to the system p<sub>1</sub> = a<sub>1</sub>, &hellip;, p<sub><em>k</em></sub> = a<sub><em>k</em></sub> up to permutation of the <em>x</em><sub><em>i</em></sub> and determine the value of p<sub><em>i</em></sub> for i&gt;k.</p> The Lambert W Function on the Reals https://www.isa-afp.org/entries/Lambert_W.html https://www.isa-afp.org/entries/Lambert_W.html Manuel Eberl 24 Apr 2020 00:00:00 +0000 <p>The Lambert <em>W</em> function is a multi-valued function defined as the inverse function of <em>x</em> &#x21A6; <em>x</em> e<sup><em>x</em></sup>. Besides numerous applications in combinatorics, physics, and engineering, it also frequently occurs when solving equations containing both e<sup><em>x</em></sup> and <em>x</em>, or both <em>x</em> and log <em>x</em>.</p> <p>This article provides a definition of the two real-valued branches <em>W</em><sub>0</sub>(<em>x</em>) and <em>W</em><sub>-1</sub>(<em>x</em>) and proves various properties such as basic identities and inequalities, monotonicity, differentiability, asymptotic expansions, and the MacLaurin series of <em>W</em><sub>0</sub>(<em>x</em>) at <em>x</em> = 0.</p> Gaussian Integers https://www.isa-afp.org/entries/Gaussian_Integers.html https://www.isa-afp.org/entries/Gaussian_Integers.html Manuel Eberl 24 Apr 2020 00:00:00 +0000 <p>The Gaussian integers are the subring &#8484;[i] of the complex numbers, i. e. the ring of all complex numbers with integral real and imaginary part. This article provides a definition of this ring as well as proofs of various basic properties, such as that they form a Euclidean ring and a full classification of their primes. An executable (albeit not very efficient) factorisation algorithm is also provided.</p> <p>Lastly, this Gaussian integer formalisation is used in two short applications:</p> <ol> <li> The characterisation of all positive integers that can be written as sums of two squares</li> <li> Euclid's formula for primitive Pythagorean triples</li> </ol> <p>While elementary proofs for both of these are already available in the AFP, the theory of Gaussian integers provides more concise proofs and a more high-level view.</p> Matrices for ODEs https://www.isa-afp.org/entries/Matrices_for_ODEs.html https://www.isa-afp.org/entries/Matrices_for_ODEs.html Jonathan Julian Huerta y Munive 19 Apr 2020 00:00:00 +0000 Our theories formalise various matrix properties that serve to establish existence, uniqueness and characterisation of the solution to affine systems of ordinary differential equations (ODEs). In particular, we formalise the operator and maximum norm of matrices. Then we use them to prove that square matrices form a Banach space, and in this setting, we show an instance of Picard-Lindelöf’s theorem for affine systems of ODEs. Finally, we use this formalisation to verify three simple hybrid programs. Authenticated Data Structures As Functors https://www.isa-afp.org/entries/ADS_Functor.html https://www.isa-afp.org/entries/ADS_Functor.html Andreas Lochbihler, Ognjen Marić 16 Apr 2020 00:00:00 +0000 Authenticated data structures allow several systems to convince each other that they are referring to the same data structure, even if each of them knows only a part of the data structure. Using inclusion proofs, knowledgeable systems can selectively share their knowledge with other systems and the latter can verify the authenticity of what is being shared. In this article, we show how to modularly define authenticated data structures, their inclusion proofs, and operations thereon as datatypes in Isabelle/HOL, using a shallow embedding. Modularity allows us to construct complicated trees from reusable building blocks, which we call Merkle functors. Merkle functors include sums, products, and function spaces and are closed under composition and least fixpoints. As a practical application, we model the hierarchical transactions of <a href="https://www.canton.io">Canton</a>, a practical interoperability protocol for distributed ledgers, as authenticated data structures. This is a first step towards formalizing the Canton protocol and verifying its integrity and security guarantees. Formalization of an Algorithm for Greedily Computing Associative Aggregations on Sliding Windows https://www.isa-afp.org/entries/Sliding_Window_Algorithm.html https://www.isa-afp.org/entries/Sliding_Window_Algorithm.html Lukas Heimes, Dmitriy Traytel, Joshua Schneider 10 Apr 2020 00:00:00 +0000 Basin et al.'s <a href="https://doi.org/10.1016/j.ipl.2014.09.009">sliding window algorithm (SWA)</a> is an algorithm for combining the elements of subsequences of a sequence with an associative operator. It is greedy and minimizes the number of operator applications. We formalize the algorithm and verify its functional correctness. We extend the algorithm with additional operations and provide an alternative interface to the slide operation that does not require the entire input sequence. A Comprehensive Framework for Saturation Theorem Proving https://www.isa-afp.org/entries/Saturation_Framework.html https://www.isa-afp.org/entries/Saturation_Framework.html Sophie Tourret 09 Apr 2020 00:00:00 +0000 This Isabelle/HOL formalization is the companion of the technical report “A comprehensive framework for saturation theorem proving”, itself companion of the eponym IJCAR 2020 paper, written by Uwe Waldmann, Sophie Tourret, Simon Robillard and Jasmin Blanchette. It verifies a framework for formal refutational completeness proofs of abstract provers that implement saturation calculi, such as ordered resolution or superposition, and allows to model entire prover architectures in such a way that the static refutational completeness of a calculus immediately implies the dynamic refutational completeness of a prover implementing the calculus using a variant of the given clause loop. The technical report “A comprehensive framework for saturation theorem proving” is available <a href="http://matryoshka.gforge.inria.fr/pubs/satur_report.pdf">on the Matryoshka website</a>. The names of the Isabelle lemmas and theorems corresponding to the results in the report are indicated in the margin of the report. Formalization of an Optimized Monitoring Algorithm for Metric First-Order Dynamic Logic with Aggregations https://www.isa-afp.org/entries/MFODL_Monitor_Optimized.html https://www.isa-afp.org/entries/MFODL_Monitor_Optimized.html Thibault Dardinier, Lukas Heimes, Martin Raszyk, Joshua Schneider, Dmitriy Traytel 09 Apr 2020 00:00:00 +0000 A monitor is a runtime verification tool that solves the following problem: Given a stream of time-stamped events and a policy formulated in a specification language, decide whether the policy is satisfied at every point in the stream. We verify the correctness of an executable monitor for specifications given as formulas in metric first-order dynamic logic (MFODL), which combines the features of metric first-order temporal logic (MFOTL) and metric dynamic logic. Thus, MFODL supports real-time constraints, first-order parameters, and regular expressions. Additionally, the monitor supports aggregation operations such as count and sum. This formalization, which is described in a <a href="http://people.inf.ethz.ch/trayteld/papers/ijcar20-verimonplus/verimonplus.pdf"> forthcoming paper at IJCAR 2020</a>, significantly extends <a href="https://www.isa-afp.org/entries/MFOTL_Monitor.html">previous work on a verified monitor</a> for MFOTL. Apart from the addition of regular expressions and aggregations, we implemented <a href="https://www.isa-afp.org/entries/Generic_Join.html">multi-way joins</a> and a specialized sliding window algorithm to further optimize the monitor. Stateful Protocol Composition and Typing https://www.isa-afp.org/entries/Stateful_Protocol_Composition_and_Typing.html https://www.isa-afp.org/entries/Stateful_Protocol_Composition_and_Typing.html Andreas V. Hess, Sebastian Mödersheim, Achim D. Brucker 08 Apr 2020 00:00:00 +0000 We provide in this AFP entry several relative soundness results for security protocols. In particular, we prove typing and compositionality results for stateful protocols (i.e., protocols with mutable state that may span several sessions), and that focuses on reachability properties. Such results are useful to simplify protocol verification by reducing it to a simpler problem: Typing results give conditions under which it is safe to verify a protocol in a typed model where only "well-typed" attacks can occur whereas compositionality results allow us to verify a composed protocol by only verifying the component protocols in isolation. The conditions on the protocols under which the results hold are furthermore syntactic in nature allowing for full automation. The foundation presented here is used in another entry to provide fully automated and formalized security proofs of stateful protocols. Automated Stateful Protocol Verification https://www.isa-afp.org/entries/Automated_Stateful_Protocol_Verification.html https://www.isa-afp.org/entries/Automated_Stateful_Protocol_Verification.html Andreas V. Hess, Sebastian Mödersheim, Achim D. Brucker, Anders Schlichtkrull 08 Apr 2020 00:00:00 +0000 In protocol verification we observe a wide spectrum from fully automated methods to interactive theorem proving with proof assistants like Isabelle/HOL. In this AFP entry, we present a fully-automated approach for verifying stateful security protocols, i.e., protocols with mutable state that may span several sessions. The approach supports reachability goals like secrecy and authentication. We also include a simple user-friendly transaction-based protocol specification language that is embedded into Isabelle. Lucas's Theorem https://www.isa-afp.org/entries/Lucas_Theorem.html https://www.isa-afp.org/entries/Lucas_Theorem.html Chelsea Edmonds 07 Apr 2020 00:00:00 +0000 This work presents a formalisation of a generating function proof for Lucas's theorem. We first outline extensions to the existing Formal Power Series (FPS) library, including an equivalence relation for coefficients modulo <em>n</em>, an alternate binomial theorem statement, and a formalised proof of the Freshman's dream (mod <em>p</em>) lemma. The second part of the work presents the formal proof of Lucas's Theorem. Working backwards, the formalisation first proves a well known corollary of the theorem which is easier to formalise, and then applies induction to prove the original theorem statement. The proof of the corollary aims to provide a good example of a formalised generating function equivalence proof using the FPS library. The final theorem statement is intended to be integrated into the formalised proof of Hilbert's 10th Problem. Strong Eventual Consistency of the Collaborative Editing Framework WOOT https://www.isa-afp.org/entries/WOOT_Strong_Eventual_Consistency.html https://www.isa-afp.org/entries/WOOT_Strong_Eventual_Consistency.html Emin Karayel, Edgar Gonzàlez 25 Mar 2020 00:00:00 +0000 Commutative Replicated Data Types (CRDTs) are a promising new class of data structures for large-scale shared mutable content in applications that only require eventual consistency. The WithOut Operational Transforms (WOOT) framework is a CRDT for collaborative text editing introduced by Oster et al. (CSCW 2006) for which the eventual consistency property was verified only for a bounded model to date. We contribute a formal proof for WOOTs strong eventual consistency. Furstenberg's topology and his proof of the infinitude of primes https://www.isa-afp.org/entries/Furstenberg_Topology.html https://www.isa-afp.org/entries/Furstenberg_Topology.html Manuel Eberl 22 Mar 2020 00:00:00 +0000 <p>This article gives a formal version of Furstenberg's topological proof of the infinitude of primes. He defines a topology on the integers based on arithmetic progressions (or, equivalently, residue classes). Using some fairly obvious properties of this topology, the infinitude of primes is then easily obtained.</p> <p>Apart from this, this topology is also fairly ‘nice’ in general: it is second countable, metrizable, and perfect. All of these (well-known) facts are formally proven, including an explicit metric for the topology given by Zulfeqarr.</p> An Under-Approximate Relational Logic https://www.isa-afp.org/entries/Relational-Incorrectness-Logic.html https://www.isa-afp.org/entries/Relational-Incorrectness-Logic.html Toby Murray 12 Mar 2020 00:00:00 +0000 Recently, authors have proposed under-approximate logics for reasoning about programs. So far, all such logics have been confined to reasoning about individual program behaviours. Yet there exist many over-approximate relational logics for reasoning about pairs of programs and relating their behaviours. We present the first under-approximate relational logic, for the simple imperative language IMP. We prove our logic is both sound and complete. Additionally, we show how reasoning in this logic can be decomposed into non-relational reasoning in an under-approximate Hoare logic, mirroring Beringer’s result for over-approximate relational logics. We illustrate the application of our logic on some small examples in which we provably demonstrate the presence of insecurity. - - Hello World - https://www.isa-afp.org/entries/Hello_World.html - https://www.isa-afp.org/entries/Hello_World.html - Cornelius Diekmann, Lars Hupel - 07 Mar 2020 00:00:00 +0000 - -In this article, we present a formalization of the well-known -"Hello, World!" code, including a formal framework for -reasoning about IO. Our model is inspired by the handling of IO in -Haskell. We start by formalizing the 🌍 and embrace the IO monad -afterwards. Then we present a sample main :: IO (), followed by its -proof of correctness. - - - Implementing the Goodstein Function in λ-Calculus - https://www.isa-afp.org/entries/Goodstein_Lambda.html - https://www.isa-afp.org/entries/Goodstein_Lambda.html - Bertram Felgenhauer - 21 Feb 2020 00:00:00 +0000 - -In this formalization, we develop an implementation of the Goodstein -function G in plain &lambda;-calculus, linked to a concise, self-contained -specification. The implementation works on a Church-encoded -representation of countable ordinals. The initial conversion to -hereditary base 2 is not covered, but the material is sufficient to -compute the particular value G(16), and easily extends to other fixed -arguments. - - - A Generic Framework for Verified Compilers - https://www.isa-afp.org/entries/VeriComp.html - https://www.isa-afp.org/entries/VeriComp.html - Martin Desharnais - 10 Feb 2020 00:00:00 +0000 - -This is a generic framework for formalizing compiler transformations. -It leverages Isabelle/HOL’s locales to abstract over concrete -languages and transformations. It states common definitions for -language semantics, program behaviours, forward and backward -simulations, and compilers. We provide generic operations, such as -simulation and compiler composition, and prove general (partial) -correctness theorems, resulting in reusable proof components. - - - Arithmetic progressions and relative primes - https://www.isa-afp.org/entries/Arith_Prog_Rel_Primes.html - https://www.isa-afp.org/entries/Arith_Prog_Rel_Primes.html - José Manuel Rodríguez Caballero - 01 Feb 2020 00:00:00 +0000 - -This article provides a formalization of the solution obtained by the -author of the Problem “ARITHMETIC PROGRESSIONS” from the -<a href="https://www.ocf.berkeley.edu/~wwu/riddles/putnam.shtml"> -Putnam exam problems of 2002</a>. The statement of the problem is -as follows: For which integers <em>n</em> > 1 does the set of positive -integers less than and relatively prime to <em>n</em> constitute an -arithmetic progression? - - - A Hierarchy of Algebras for Boolean Subsets - https://www.isa-afp.org/entries/Subset_Boolean_Algebras.html - https://www.isa-afp.org/entries/Subset_Boolean_Algebras.html - Walter Guttmann, Bernhard Möller - 31 Jan 2020 00:00:00 +0000 - -We present a collection of axiom systems for the construction of -Boolean subalgebras of larger overall algebras. The subalgebras are -defined as the range of a complement-like operation on a semilattice. -This technique has been used, for example, with the antidomain -operation, dynamic negation and Stone algebras. We present a common -ground for these constructions based on a new equational -axiomatisation of Boolean algebras. - diff --git a/web/statistics.html b/web/statistics.html --- a/web/statistics.html +++ b/web/statistics.html @@ -1,307 +1,307 @@ Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Statistics

 

Statistics

- - - - + + + +
Number of Articles:546
Number of Authors:360
Number of lemmas:~147,900
Lines of Code:~2,583,300
Number of Articles:551
Number of Authors:361
Number of lemmas:~148,900
Lines of Code:~2,609,400

Most used AFP articles:

+ + + + - - - -
NameUsed by ? articles
1. List-Index 15
2. Coinductive 12
Collections 12
Regular-Sets 12
3. Landau_Symbols 11
4.Polynomial_Factorization10
Show 10
5. Abstract-Rewriting 9
Automatic_Refinement 9
Deriving 9
Polynomial_Factorization9
6. Jordan_Normal_Form 8
Native_Word 8

Growth in number of articles:

Growth in lines of code:

Growth in number of authors:

Size of articles:
\ No newline at end of file diff --git a/web/topics.html b/web/topics.html --- a/web/topics.html +++ b/web/topics.html @@ -1,893 +1,899 @@ Archive of Formal Proofs

 

 

 

Home
About
Submission
Updating Entries
Using Entries
Search
Statistics
Index
Download

 

 

 

Index by Topic

 

Computer science

Automata and formal languages

Partial_Order_Reduction   C2KA_DistributedSystems   Posix-Lexing   LocalLexing   KBPs   Regular-Sets   Regex_Equivalence   MSO_Regex_Equivalence   Formula_Derivatives   Myhill-Nerode   Universal_Turing_Machine   CYK   Presburger-Automata   Functional-Automata   Statecharts   Stuttering_Equivalence   Coinductive_Languages   Tree-Automata   Kleene_Algebra   KAT_and_DRA   KAD   Regular_Algebras   Markov_Models   Probabilistic_System_Zoo   CAVA_Automata   LTL   LTL_to_GBA   CAVA_LTL_Modelchecker   Probabilistic_Timed_Automata   Finite_Automata_HF   LTL_to_DRA   Timed_Automata   Stochastic_Matrices   Buchi_Complementation   Transition_Systems_and_Automata   Factored_Transition_System_Bounding   LTL_Master_Theorem   MFOTL_Monitor   Adaptive_State_Counting   MFODL_Monitor_Optimized   LTL_Normal_Form  

Algorithms

Knuth_Morris_Pratt   Probabilistic_While   Comparison_Sort_Lower_Bound   Quick_Sort_Cost   TortoiseHare   Selection_Heap_Sort   VerifyThis2018   CYK   Boolean_Expression_Checkers   Efficient-Mergesort   SATSolverVerification   MuchAdoAboutTwo   First_Order_Terms   Monad_Memo_DP   Hidden_Markov_Models   Imperative_Insertion_Sort   Formal_SSA   ROBDD   Median_Of_Medians_Selection   Fisher_Yates   Optimal_BST   IMP2   Auto2_Imperative_HOL   List_Inversions   IMP2_Binary_Heap   MFOTL_Monitor   Adaptive_State_Counting   Generic_Join   VerifyThis2019   Generalized_Counting_Sort   MFODL_Monitor_Optimized   Sliding_Window_Algorithm   Graph: DFS_Framework   Prpu_Maxflow   Floyd_Warshall   Roy_Floyd_Warshall   Dijkstra_Shortest_Path   EdmondsKarp_Maxflow   Depth-First-Search   GraphMarkingIBP   Transitive-Closure   Transitive-Closure-II   Gabow_SCC   Kruskal   Prim_Dijkstra_Simple   Distributed: DiskPaxos   GenClock   ClockSynchInst   Heard_Of   Consensus_Refined   Abortable_Linearizable_Modules   IMAP-CRDT   CRDT   + Chandy_Lamport   OpSets   Stellar_Quorums   WOOT_Strong_Eventual_Consistency   Concurrent: ConcurrentGC   Online: List_Update   Geometry: Closest_Pair_Points   Approximation: Approximation_Algorithms   Mathematical: FFT   Gauss-Jordan-Elim-Fun   UpDown_Scheme   Polynomials   Gauss_Jordan   Echelon_Form   QR_Decomposition   Hermite   Groebner_Bases   Diophantine_Eqns_Lin_Hom   Taylor_Models   LLL_Basis_Reduction   Signature_Groebner   Smith_Normal_Form   Safe_Distance   Optimization: Simplex  

Concurrency

FLP   Concurrent_Ref_Alg   Concurrent_Revisions   Store_Buffer_Reduction   TESL_Language   Process calculi: Noninterference_Generic_Unwinding   AODV   AWN   CCS   Pi_Calculus   Psi_Calculi   Encodability_Process_Calculi   Circus   Noninterference_Sequential_Composition   Noninterference_Concurrent_Composition   Modal_Logics_for_NTS   HOL-CSP  

Data structures

Generic_Deriving   Random_BSTs   Randomised_BSTs   List_Interleaving   Refine_Imperative_HOL   Amortized_Complexity   Dynamic_Tables   AVL-Trees   BDD   BinarySearchTree   Splay_Tree   Root_Balanced_Tree   Skew_Heap   Pairing_Heap   Priority_Queue_Braun   Binomial-Queues   Binomial-Heaps   Finger-Trees   Trie   FinFun   Collections   Containers   FileRefinement   Datatype_Order_Generator   Deriving   List-Index   List-Infinite   Matrix   Matrix_Tensor   Huffman   Lazy-Lists-II   IEEE_Floating_Point   Native_Word   XML   ROBDD   IMAP-CRDT   Word_Lib   CRDT   KD_Tree   Taylor_Models   Treaps   Skip_Lists   Weight_Balanced_Trees   OpSets   Optimal_BST   Core_DOM   Auto2_Imperative_HOL   IMP2_Binary_Heap   Priority_Search_Trees   Interval_Arithmetic_Word32   ADS_Functor   + Relational_Disjoint_Set_Forests  

Functional programming

Optics   CryptHOL   Probabilistic_While   Monad_Normalisation   Monomorphic_Monad   Show   Certification_Monads   Partial_Function_MR   Lifting_Definition_Option   Coinductive   Stream-Fusion   Tycon   Monad_Memo_DP   XML   Tail_Recursive_Functions   Stream_Fusion_Code   Applicative_Lifting   HOLCF-Prelude   BNF_CC   Binding_Syntax_Theory   Generalized_Counting_Sort   Hello_World  

Hardware

SPARCv8  

Machine learning

Deep_Learning  

Networks

UPF_Firewall   IP_Addresses   Simple_Firewall   Iptables_Semantics   Routing   LOFT  

Programming languages

Clean   Decl_Sem_Fun_PL   Language definitions: CakeML   WebAssembly   pGCL   GPU_Kernel_PL   LightweightJava   CoreC++   FeatherweightJava   Jinja   JinjaThreads   Locally-Nameless-Sigma   AutoFocus-Stream   FocusStreamsCaseStudies   Isabelle_Meta_Model   Simpl   Complx   Safe_OCL   Isabelle_C   Lambda calculi: Higher_Order_Terms   Launchbury   PCF   POPLmark-deBruijn   Lam-ml-Normalization   LambdaMu   Binding_Syntax_Theory   LambdaAuth   Type systems: Name_Carrying_Type_Inference   MiniML   Possibilistic_Noninterference   SIFUM_Type_Systems   Dependent_SIFUM_Type_Systems   Strong_Security   WHATandWHERE_Security   VolpanoSmith   Logics: ConcurrentIMP   Refine_Monadic   Automatic_Refinement   MonoBoolTranAlgebra   Simpl   Separation_Algebra   Separation_Logic_Imperative_HOL   Relational-Incorrectness-Logic   Abstract-Hoare-Logics   Kleene_Algebra   KAT_and_DRA   KAD   BytecodeLogicJmlTypes   DataRefinementIBP   RefinementReactive   SIFPL   TLA   Ribbon_Proofs   Separata   Complx   Differential_Dynamic_Logic   Hoare_Time   IMP2   UTP   QHLProver   Differential_Game_Logic   Compiling: CakeML_Codegen   Compiling-Exceptions-Correctly   NormByEval   Density_Compiler   VeriComp   Static analysis: RIPEMD-160-SPARK   Program-Conflict-Analysis   Shivers-CFA   Slicing   HRB-Slicing   InfPathElimination   Abs_Int_ITP2012   Transformations: Call_Arity   Refine_Imperative_HOL   WorkerWrapper   Monad_Memo_DP   Formal_SSA   Minimal_SSA   Misc: JiveDataStoreModel   Pop_Refinement   Case_Labeling  

Security

Multi_Party_Computation   Noninterference_Generic_Unwinding   Noninterference_Ipurge_Unwinding   UPF   UPF_Firewall   CISC-Kernel   Noninterference_CSP   Key_Agreement_Strong_Adversaries   Security_Protocol_Refinement   Attack_Trees   Inductive_Confidentiality   Possibilistic_Noninterference   SIFUM_Type_Systems   Dependent_SIFUM_Type_Systems   Dependent_SIFUM_Refinement   Relational-Incorrectness-Logic   Strong_Security   WHATandWHERE_Security   VolpanoSmith   SIFPL   HotelKeyCards   InformationFlowSlicing   InformationFlowSlicing_Inter   CryptoBasedCompositionalProperties   Probabilistic_Noninterference   HyperCTL   Bounded_Deducibility_Security   Network_Security_Policy_Verification   Noninterference_Inductive_Unwinding   Password_Authentication_Protocol   Noninterference_Sequential_Composition   Noninterference_Concurrent_Composition   SPARCv8   Modular_Assembly_Kit_Security   LambdaAuth   Stateful_Protocol_Composition_and_Typing   Automated_Stateful_Protocol_Verification   Cryptography: Game_Based_Crypto   Sigma_Commit_Crypto   CryptHOL   Constructive_Cryptography   RSAPSS   Elliptic_Curves_Group_Law  

Semantics

Launchbury   Clean   Transformer_Semantics   HOL-CSP   QHLProver   TESL_Language   Isabelle_C  

System description languages

Circus   ComponentDependencies   Promela   Featherweight_OCL   DynamicArchitectures   Architectural_Design_Patterns   TESL_Language  

Logic

Philosophical aspects

GoedelGod   Types_Tableaus_and_Goedels_God   GewirthPGCProof   Lowe_Ontological_Argument   AnselmGod   PLM   Aristotles_Assertoric_Syllogistic  

General logic

Classical propositional logic: Free-Boolean-Algebra   Classical first-order logic: FOL-Fitting   Decidability of theories: MSO_Regex_Equivalence   Formula_Derivatives   Presburger-Automata   LinearQuantifierElim   Mechanization of proofs: Boolean_Expression_Checkers   Verified-Prover   Sort_Encodings   PropResPI   Resolution_FOL   FOL_Harrison   Ordered_Resolution_Prover   Functional_Ordered_Resolution_Prover   Binding_Syntax_Theory   Saturation_Framework   Saturation_Framework_Extensions   Lambda calculus: LambdaMu   Logics of knowledge and belief: Epistemic_Logic   Temporal logic: Nat-Interval-Logic   LTL   HyperCTL   Allen_Calculus   MFOTL_Monitor   LTL_Normal_Form   Modal logic: Modal_Logics_for_NTS   Differential_Dynamic_Logic   Hybrid_Multi_Lane_Spatial_Logic   Hybrid_Logic   MFODL_Monitor_Optimized   Paraconsistent logics: Paraconsistency  

Computability

Universal_Turing_Machine   Recursion-Theory-I   Minsky_Machines  

Set theory

Ordinal   Ordinals_and_Cardinals   HereditarilyFinite   ZFC_in_HOL   Forcing   Recursion-Addition   + Ordinal_Partitions  

Proof theory

Propositional_Proof_Systems   Completeness   SequentInvertibility   Incompleteness   Abstract_Completeness   SuperCalc   Incredible_Proof_Machine   Surprise_Paradox   Abstract_Soundness   FOL_Seq_Calc1  

Rewriting

CakeML_Codegen   Monad_Normalisation   Lambda_Free_RPOs   Lambda_Free_KBOs   Lambda_Free_EPO   Nested_Multisets_Ordinals   Abstract-Rewriting   First_Order_Terms   Decreasing-Diagrams   Decreasing-Diagrams-II   Rewriting_Z   Graph_Saturation   Goodstein_Lambda   Knuth_Bendix_Order  

Mathematics

Order

LatticeProperties   Stone_Algebras   Allen_Calculus   Order_Lattice_Props   Complete_Non_Orders   Szpilrajn  

Algebra

Optics   Subresultants   Buildings   Algebraic_VCs   C2KA_DistributedSystems   Multirelations   Residuated_Lattices   PseudoHoops   Impossible_Geometry   Gauss-Jordan-Elim-Fun   Matrix_Tensor   Kleene_Algebra   KAT_and_DRA   KAD   Regular_Algebras   Free-Groups   CofGroups   Group-Ring-Module   Robbins-Conjecture   Valuation   Rank_Nullity_Theorem   Polynomials   Relation_Algebra   PSemigroupsConvolution   Secondary_Sylow   Jordan_Hoelder   Cayley_Hamilton   VectorSpace   Echelon_Form   QR_Decomposition   Hermite   Rep_Fin_Groups   Jordan_Normal_Form   Algebraic_Numbers   Polynomial_Interpolation   Polynomial_Factorization   Perron_Frobenius   Stochastic_Matrices   Groebner_Bases   Nullstellensatz   Mason_Stothers   Berlekamp_Zassenhaus   Stone_Relation_Algebras   Stone_Kleene_Relation_Algebras   Orbit_Stabiliser   Dirichlet_L   Symmetric_Polynomials   Taylor_Models   LLL_Basis_Reduction   LLL_Factorization   Localization_Ring   Quaternions   Octonions   Aggregation_Algebras   Signature_Groebner   Quantales   Transformer_Semantics   Farkas   Groebner_Macaulay   Linear_Inequalities   Linear_Programming   Jacobson_Basic_Algebra   Hybrid_Systems_VCs   Subset_Boolean_Algebras   Power_Sum_Polynomials   Matrices_for_ODEs   Smith_Normal_Form  

Analysis

Banach_Steinhaus   Fourier   E_Transcendental   Liouville_Numbers   Descartes_Sign_Rule   Euler_MacLaurin   Real_Impl   Lower_Semicontinuous   Affine_Arithmetic   Laplace_Transform   Cauchy   Integration   Ordinary_Differential_Equations   Polynomials   Sqrt_Babylonian   Sturm_Sequences   Sturm_Tarski   Special_Function_Bounds   Landau_Symbols   Error_Function   Akra_Bazzi   Zeta_Function   Linear_Recurrences   Lambert_W   Cartan_FP   Deep_Learning   Stirling_Formula   Lp   Bernoulli   Winding_Number_Eval   Count_Complex_Roots   Taylor_Models   Green   Irrationality_J_Hancl   Budan_Fourier   Smooth_Manifolds   Transcendence_Series_Hancl_Rucki   Hybrid_Systems_VCs   Poincare_Bendixson   Matrices_for_ODEs   Irrational_Series_Erdos_Straus  

Probability theory

DiscretePricing   CryptHOL   Constructive_Cryptography   Probabilistic_While   Markov_Models   Density_Compiler   Probabilistic_Timed_Automata   Hidden_Markov_Models   Random_Graph_Subgraph_Threshold   Ergodic_Theory   Source_Coding_Theorem   Buffons_Needle  

Number theory

Arith_Prog_Rel_Primes   Pell   Minkowskis_Theorem   E_Transcendental   Pi_Transcendental   Liouville_Numbers   Prime_Harmonic_Series   Fermat3_4   Perfect-Number-Thm   SumSquares   Lehmer   Pratt_Certificate   Dirichlet_Series   Gauss_Sums   Zeta_Function   Stern_Brocot   Bertrands_Postulate   Bernoulli   Diophantine_Eqns_Lin_Hom   Dirichlet_L   Mersenne_Primes   Irrationality_J_Hancl   Prime_Number_Theorem   Probabilistic_Prime_Tests   Prime_Distribution_Elementary   Transcendence_Series_Hancl_Rucki   Zeta_3_Irrational   Furstenberg_Topology   Lucas_Theorem   Gaussian_Integers   Irrational_Series_Erdos_Straus   + Amicable_Numbers  

Games and economics

DiscretePricing   ArrowImpossibilityGS   SenSocialChoice   Vickrey_Clarke_Groves   Parity_Game   First_Welfare_Theorem   Randomised_Social_Choice   SDS_Impossibility   Stable_Matching   Fishburn_Impossibility   Neumann_Morgenstern_Utility  

Geometry

Complex_Geometry   Poincare_Disc   Minkowskis_Theorem   Buildings   Chord_Segments   Triangle   Impossible_Geometry   Tarskis_Geometry   General-Triangle   Nullstellensatz   Ptolemys_Theorem   Buffons_Needle   Stewart_Apollonius   Gromov_Hyperbolicity   Projective_Geometry   Quaternions   Octonions  

Topology

Topology   Knot_Theory   Kuratowski_Closure_Complement   Smooth_Manifolds  

Graph theory

Flow_Networks   Prpu_Maxflow   MFMC_Countable   ShortestPath   Gabow_SCC   Graph_Theory   Planarity_Certificates   Max-Card-Matching   Girth_Chromatic   Random_Graph_Subgraph_Threshold   Flyspeck-Tame   Koenigsberg_Friendship   Tree_Decomposition   Menger   Parity_Game   Factored_Transition_System_Bounding   Graph_Saturation   + Relational_Paths  

Combinatorics

Card_Equiv_Relations   Twelvefold_Way   Card_Multisets   Card_Partitions   Card_Number_Partitions   Well_Quasi_Orders   Marriage   Bondy   Ramsey-Infinite   Derangements   Euler_Partition   Discrete_Summation   Open_Induction   Latin_Square   Bell_Numbers_Spivey   Catalan_Numbers   Falling_Factorial_Sum   Matroids   Nash_Williams   + Ordinal_Partitions  

Category theory

Category3   MonoidalCategory   Category   Category2   AxiomaticCategoryTheory   Bicategory  

Physics

No_FTL_observers   Safe_Distance  

Misc

FunWithFunctions   FunWithTilings   IMO2019  

Tools

Monad_Normalisation   Constructor_Funs   Lazy_Case   Dict_Construction   Case_Labeling   DPT-SAT-Solver   Nominal2   Separata   Proof_Strategy_Language   Diophantine_Eqns_Lin_Hom   BNF_Operations   BNF_CC   Auto2_HOL   Isabelle_C   Automated_Stateful_Protocol_Verification  
\ No newline at end of file